Frosty
02-17-2011, 10:34 AM
After a lot of research, I thought I'd post my solution to having dynamic custom images in a Word project. Much of this was adapted from rondebruin.nl/getimage.htm, although there were a few tricks to getting it to work in Word. In addition, when stepping through the original code in Excel, I was able to crash Excel a number of times. The below has seemed to work for me.
Notes:
1. I have the fCreateResoucesFolder running in an autoexec, and the fDeleteResourcesFolder running in a Quit event for the Word application. I won't expand those thoughts, as this post would become even longer.
2. I utilize a custom class called RibbonControls, which basically organizes all of my custom controls. For me, the goal is to be able to dynamically adjust the Ribbon, and since the programmatic access to the ribbon is very limited, I've found the need to basically create private arrays with all of the custom data I'd want and store it in various ways within my RibbonControls class. In order to use this code, you'd need at least a moderate understanding of being able to read most of it... so just as a note, you would need to modify the getImage routine to use your own custom controls and values. myRibbonControls class also returns back either a custom image value or an msoimage value, which is why getImage deals differently depending on what it is expecting. I leave that code in as a suggestion for anyone else doing this (and to open myself up to comments for a better way of doing it).
But everything else should be fairly universal.
Having this kind of code in a forum like this may help Microsoft to add this kind of functionality without having to search everywhere for it. It certainly would have shortened my research time in preparing to go from Office 2003 to 2010.
Basically, the sum up is that, despite almost everything I'd read on the internet, we do not need to write a custom addin in Visual Studio to dynamically assign images to our Ribbon controls. We can do it all from with VBA.
I've left in comments attributing credit to the original authors of the code, hopefully not missing anything. In no way am I saying this is "my" code... it is an amalgamation of my organization and tweaks, with the "hard stuff" (especially the conversion to IPicture) done mostly by others.
Hope this helps someone else.
- Jason
'----------------------------------------------------------------------------------------------
'Declare a UDT to store a GUID for the IPicture OLE Interface
'----------------------------------------------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'----------------------------------------------------------------------------------------------
' Variable declares for the LoadPictureGDI functions
'----------------------------------------------------------------------------------------------
#If VBA7 Then
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'Windows API calls into the GDI+ library
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" _
(ByVal filename As LongPtr, _
bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" _
(ByVal bitmap As LongPtr, hbmReturn As LongPtr, _
ByVal background As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" _
(ByVal Image As LongPtr) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" _
(PicDesc As PICTDESC, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'----------------------------------------------------------------------------------------------
#Else
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'Windows API calls into the GDI+ library
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, _
bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
#End If
'----------------------------------------------------------------------------------------------
' The location of our custom images folder, may need to set a variable during startup
' for now, hard coded
' It may be useful to add in Format(Now, "dd-mmm-yy h-mm-ss") to the folder name
' to prevent conflicts.
' also, it may be good to put it in the Environ("temp") location, rather than C:\Temp
'----------------------------------------------------------------------------------------------
Public Function fGetResourcesFolderPath(Optional bFullPathImages As Boolean = True) As String
Dim sFileName As String
Dim sPath As String
Dim sRet As String
'get this project name
sFileName = ThisDocument.Name
'remove the file extension
sFileName = Left(sFileName, InStrRev(sFileName, ".") - 1)
'add the subfolders to the images location
If bFullPathImages Then
sRet = "\" & sFileName & "\customUI\images"
End If
'prepend the path
'same folder as the project
'sPath = ThisDocument.Path & "\"
'designated scratch folder?
'sPath = "C:\Temp"
'folder in the profile
sPath = Environ("temp")
'now actually set it
sRet = sPath & sRet
'and return it
fGetResourcesFolderPath = sRet
End Function
'----------------------------------------------------------------------------------------------
' This procedure assumes a macro template in the 2007/2010 format (which is really just a .zip)
' And then creates a folder with those resources.
'
' It performs the following actions:
' 1. Attempts to delete any pre-existing version of the resources folder
' 2. Creates a .zip copy of the passed filename using the filesystemobject
' 3. Extract the files from that .zip file into a folder in the same location
' 4. Deletes the created .zip file
'
' FOLLOWUP: need to see why the file copy screen shows up, network drive? move to appdata
' the way the excel version was? Need to change folder name to time/date stamp to
' deal with any word crashes not doing the clean up?
'----------------------------------------------------------------------------------------------
Public Function fCreateResourcesFolder(Optional oDocToCopy As Document, _
Optional bImagesOnly As Boolean = True) As Integer
Dim oFSO As Object
Dim oFile As Object
Dim oApp As Object
Dim sNewName As String
Dim lCopyHereParams As Long
On Error GoTo l_err
'we need to be careful of running this multiple times
'Let us know what we're doing
Application.StatusBar = "Creating resoures folder"
'since the use of the copyhere parameters seems to work intermittently, try to delete it first
fDeleteResourcesFolder
'default to this project, if I haven't passed in a document
If oDocToCopy Is Nothing Then
Set oDocToCopy = ThisDocument
End If
'start working on the new name of our file
sNewName = Left(oDocToCopy.Name, InStrRev(oDocToCopy.Name, ".") - 1)
'add the resources path to the front of it
sNewName = fGetResourcesFolderPath(False) & "\" & sNewName
'Now create an instance of the FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
'create a reference to the file to copy
Set oFile = oFSO.GetFile(oDocToCopy.FullName)
'and create a copy of the file
oFile.Copy sNewName & ".zip"
'now create our new folder of the same name as the .zip file, skipping any returned errors
On Error Resume Next
MkDir sNewName
'now just create the sub-folders, if image only is desired
If bImagesOnly Then
MkDir sNewName & "\customUI"
MkDir sNewName & "\customUI\images"
End If
On Error GoTo l_err
'*** extract the files from our .zip file into the new folder
'create an instance of the shell
Set oApp = CreateObject("Shell.Application")
'the following items must be added in some combination to add options to CopyHere
'from msdn.microsoft.com/en-us/library/bb787866%28VS.85%29.aspx
'(4) Do not display a progress dialog box.
'(8) Give the file being operated on a new name in a move, copy, or rename operation
' if a file with the target name already exists.
'(16) Respond with "Yes to All" for any dialog box that is displayed.
'(64) Preserve undo information, if possible.
'(128) Perform the operation on files only if a wildcard file name (*.*) is specified.
'(256) Display a progress dialog box but do not show the file names.
'(512) Do not confirm the creation of a new directory if the operation requires one to be created.
'(1024) Do not display a user interface if an error occurs.
'(2048) Version 4.71. Do not copy the security attributes of the file.
'(4096) Only operate in the local directory. Do not operate recursively into subdirectories.
'(8192) Version 5.0. Do not copy connected files as a group. Only copy the specified files.
'***JFS NOTE: these params worked at first, and then stopped working
'set our params from above
lCopyHereParams = 4 + 16 + 512 + 1024
'If we indicated images, only copy that folder structure
If bImagesOnly Then
oApp.Namespace(sNewName & "\customUI\images\").CopyHere _
oApp.Namespace(sNewName & ".zip\customUI\images").Items, lCopyHereParams
Else
oApp.Namespace(sNewName & "\").CopyHere _
oApp.Namespace(sNewName & ".zip").Items, lCopyHereParams
End If
'let us know we're done
Application.StatusBar = "Done creating resoures folder"
l_exit:
'garbage collection
On Error Resume Next
Kill sNewName & ".zip"
Set oFSO = Nothing
Set oFile = Nothing
Application.ScreenUpdating = True
Exit Function
l_err:
fCreateResourcesFolder = -1000
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------
' Delete the passed in folder
' If parameter isn't passed, defaults to a folder named the same as this project
' in the same folder as this project
'----------------------------------------------------------------------------------------------
Public Function fDeleteResourcesFolder(Optional sFolderName As String) As Integer
Dim oFSO As Object
On Error GoTo l_err
'what am I working on?
If sFolderName = "" Then
sFolderName = fGetResourcesFolderPath(False) & "\"
sFolderName = sFolderName & Left(ThisDocument.Name, InStrRev(ThisDocument.Name, ".") - 1)
End If
'Now create an instance of the FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
'if we've got a slash
If Right(sFolderName, 1) = "\" Then
'get rid of it
sFolderName = Left(sFolderName, Len(sFolderName) - 1)
End If
'Attempt to delete it
On Error Resume Next
oFSO.deletefolder sFolderName
On Error GoTo l_err
l_exit:
'garbage cleanup
On Error Resume Next
Set oFSO = Nothing
Exit Function
l_err:
fDeleteResourcesFolder = -1000
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------
'Callback for getImage
'Note: different process to use microsoft built-in images vs. other kinds of images
'although the code which uses the fLoadPictureGDI comes from an Excel project,
'it was modified to be able to be used in Word
'(thus the use of the object variable as an intermediary)
'----------------------------------------------------------------------------------------------
Public Sub getImage(control As IRibbonControl, ByRef ReturnedVal)
Dim sPicName As String
Dim oRet As Object
Dim sRet As String
Dim sSize As String
Dim sImagePath As String
Dim sImageExtension As String
On Error GoTo l_err
'get some defaults
sImageExtension = ".png"
'sImagePath = ThisDocument.Path & "\CustomImages\"
sImagePath = fGetResourcesFolderPath & "\"
'this should give us the name of a custom image or a builtin microsoft image
sRet = myRibbonControls(control.ID).Image
'we do different processes, if we're using a custom image
If myRibbonControls.ImageUsingCustom = True Then
'load the image
Set oRet = fLoadPictureGDI(sImagePath & sRet & sImageExtension)
'if we got nothing from our first loading attempt
If oRet Is Nothing Then
'try our default custom image, with the appropriate size
If myRibbonControls(control.ID).Size Then
sSize = "_32"
Else
sSize = "_16"
End If
'this loads the default image
Set oRet = fLoadPictureGDI(sImagePath & "JMBM" & sSize & sImageExtension)
End If
'If we were still unsuccessful, but we're looking for an image, give one
If oRet Is Nothing Then
ReturnedVal = "FileNew"
'this should be our custom image, whether the default custom or the assigned one
Else
Set ReturnedVal = oRet
End If
Else 'built-in image
If sRet = "" Then
'use a blank page as our default "image"
sRet = "ButtonTaskSelfSupport"
End If
ReturnedVal = sRet
End If
l_exit:
Exit Sub
l_err:
'if any error, just show a built-in control of the question mark variety
ReturnedVal = "ButtonTaskSelfSupport"
Resume l_exit
End Sub
'----------------------------------------------------------------------------------------------
'This module provides a LoadPictureGDI function, which can
'be used instead of VBA's LoadPicture, to load a wide variety
'of image types from disk - including png.
'
'The png format is used in Office 2007-2010 to provide images that
'include an alpha channel for each pixel's transparency
'
'Author: Stephen Bullen
'Date: 31 October, 2006
'Email: stephen@oaltd.co.uk
'Updated : 30 December, 2010
'By : Rob Bovey
'Reason : Also working now in the 64 bit version of Office 2010
'----------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------
' Procedure: LoadPictureGDI
' Purpose: Loads an image using GDI+
' Returns: The image as an IPicture Object
'----------------------------------------------------------------------------------------------
Public Function fLoadPictureGDI(ByVal sFileName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim lResult As Long
#If VBA7 Then
Dim hGdiPlus As LongPtr
Dim hGdiImage As LongPtr
Dim hBitmap As LongPtr
#Else
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
#End If
'Initialize GDI+
uGdiInput.GdiplusVersion = 1
lResult = GdiplusStartup(hGdiPlus, uGdiInput)
If lResult = 0 Then
'Load the image
lResult = GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage)
If lResult = 0 Then
'Create a bitmap handle from the GDI image
lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)
'Create the IPicture object from the bitmap handle
Set fLoadPictureGDI = fCreateIPicture(hBitmap)
'Tidy up
GdipDisposeImage hGdiImage
End If
'Shutdown GDI+
GdiplusShutdown hGdiPlus
End If
End Function
'----------------------------------------------------------------------------------------------
' Procedure: CreateIPicture
' Purpose: Converts a image handle into an IPicture object.
' Returns: The IPicture object
'----------------------------------------------------------------------------------------------
#If VBA7 Then
Private Function fCreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function fCreateIPicture(ByVal hPic As Long) As IPicture
#End If
Dim lResult As Long
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
' Create the Picture object.
lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' Return the new Picture object.
Set fCreateIPicture = IPic
End Function
Notes:
1. I have the fCreateResoucesFolder running in an autoexec, and the fDeleteResourcesFolder running in a Quit event for the Word application. I won't expand those thoughts, as this post would become even longer.
2. I utilize a custom class called RibbonControls, which basically organizes all of my custom controls. For me, the goal is to be able to dynamically adjust the Ribbon, and since the programmatic access to the ribbon is very limited, I've found the need to basically create private arrays with all of the custom data I'd want and store it in various ways within my RibbonControls class. In order to use this code, you'd need at least a moderate understanding of being able to read most of it... so just as a note, you would need to modify the getImage routine to use your own custom controls and values. myRibbonControls class also returns back either a custom image value or an msoimage value, which is why getImage deals differently depending on what it is expecting. I leave that code in as a suggestion for anyone else doing this (and to open myself up to comments for a better way of doing it).
But everything else should be fairly universal.
Having this kind of code in a forum like this may help Microsoft to add this kind of functionality without having to search everywhere for it. It certainly would have shortened my research time in preparing to go from Office 2003 to 2010.
Basically, the sum up is that, despite almost everything I'd read on the internet, we do not need to write a custom addin in Visual Studio to dynamically assign images to our Ribbon controls. We can do it all from with VBA.
I've left in comments attributing credit to the original authors of the code, hopefully not missing anything. In no way am I saying this is "my" code... it is an amalgamation of my organization and tweaks, with the "hard stuff" (especially the conversion to IPicture) done mostly by others.
Hope this helps someone else.
- Jason
'----------------------------------------------------------------------------------------------
'Declare a UDT to store a GUID for the IPicture OLE Interface
'----------------------------------------------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'----------------------------------------------------------------------------------------------
' Variable declares for the LoadPictureGDI functions
'----------------------------------------------------------------------------------------------
#If VBA7 Then
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'Windows API calls into the GDI+ library
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" _
(ByVal filename As LongPtr, _
bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" _
(ByVal bitmap As LongPtr, hbmReturn As LongPtr, _
ByVal background As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" _
(ByVal Image As LongPtr) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" _
(PicDesc As PICTDESC, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'----------------------------------------------------------------------------------------------
#Else
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'Windows API calls into the GDI+ library
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, _
bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
#End If
'----------------------------------------------------------------------------------------------
' The location of our custom images folder, may need to set a variable during startup
' for now, hard coded
' It may be useful to add in Format(Now, "dd-mmm-yy h-mm-ss") to the folder name
' to prevent conflicts.
' also, it may be good to put it in the Environ("temp") location, rather than C:\Temp
'----------------------------------------------------------------------------------------------
Public Function fGetResourcesFolderPath(Optional bFullPathImages As Boolean = True) As String
Dim sFileName As String
Dim sPath As String
Dim sRet As String
'get this project name
sFileName = ThisDocument.Name
'remove the file extension
sFileName = Left(sFileName, InStrRev(sFileName, ".") - 1)
'add the subfolders to the images location
If bFullPathImages Then
sRet = "\" & sFileName & "\customUI\images"
End If
'prepend the path
'same folder as the project
'sPath = ThisDocument.Path & "\"
'designated scratch folder?
'sPath = "C:\Temp"
'folder in the profile
sPath = Environ("temp")
'now actually set it
sRet = sPath & sRet
'and return it
fGetResourcesFolderPath = sRet
End Function
'----------------------------------------------------------------------------------------------
' This procedure assumes a macro template in the 2007/2010 format (which is really just a .zip)
' And then creates a folder with those resources.
'
' It performs the following actions:
' 1. Attempts to delete any pre-existing version of the resources folder
' 2. Creates a .zip copy of the passed filename using the filesystemobject
' 3. Extract the files from that .zip file into a folder in the same location
' 4. Deletes the created .zip file
'
' FOLLOWUP: need to see why the file copy screen shows up, network drive? move to appdata
' the way the excel version was? Need to change folder name to time/date stamp to
' deal with any word crashes not doing the clean up?
'----------------------------------------------------------------------------------------------
Public Function fCreateResourcesFolder(Optional oDocToCopy As Document, _
Optional bImagesOnly As Boolean = True) As Integer
Dim oFSO As Object
Dim oFile As Object
Dim oApp As Object
Dim sNewName As String
Dim lCopyHereParams As Long
On Error GoTo l_err
'we need to be careful of running this multiple times
'Let us know what we're doing
Application.StatusBar = "Creating resoures folder"
'since the use of the copyhere parameters seems to work intermittently, try to delete it first
fDeleteResourcesFolder
'default to this project, if I haven't passed in a document
If oDocToCopy Is Nothing Then
Set oDocToCopy = ThisDocument
End If
'start working on the new name of our file
sNewName = Left(oDocToCopy.Name, InStrRev(oDocToCopy.Name, ".") - 1)
'add the resources path to the front of it
sNewName = fGetResourcesFolderPath(False) & "\" & sNewName
'Now create an instance of the FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
'create a reference to the file to copy
Set oFile = oFSO.GetFile(oDocToCopy.FullName)
'and create a copy of the file
oFile.Copy sNewName & ".zip"
'now create our new folder of the same name as the .zip file, skipping any returned errors
On Error Resume Next
MkDir sNewName
'now just create the sub-folders, if image only is desired
If bImagesOnly Then
MkDir sNewName & "\customUI"
MkDir sNewName & "\customUI\images"
End If
On Error GoTo l_err
'*** extract the files from our .zip file into the new folder
'create an instance of the shell
Set oApp = CreateObject("Shell.Application")
'the following items must be added in some combination to add options to CopyHere
'from msdn.microsoft.com/en-us/library/bb787866%28VS.85%29.aspx
'(4) Do not display a progress dialog box.
'(8) Give the file being operated on a new name in a move, copy, or rename operation
' if a file with the target name already exists.
'(16) Respond with "Yes to All" for any dialog box that is displayed.
'(64) Preserve undo information, if possible.
'(128) Perform the operation on files only if a wildcard file name (*.*) is specified.
'(256) Display a progress dialog box but do not show the file names.
'(512) Do not confirm the creation of a new directory if the operation requires one to be created.
'(1024) Do not display a user interface if an error occurs.
'(2048) Version 4.71. Do not copy the security attributes of the file.
'(4096) Only operate in the local directory. Do not operate recursively into subdirectories.
'(8192) Version 5.0. Do not copy connected files as a group. Only copy the specified files.
'***JFS NOTE: these params worked at first, and then stopped working
'set our params from above
lCopyHereParams = 4 + 16 + 512 + 1024
'If we indicated images, only copy that folder structure
If bImagesOnly Then
oApp.Namespace(sNewName & "\customUI\images\").CopyHere _
oApp.Namespace(sNewName & ".zip\customUI\images").Items, lCopyHereParams
Else
oApp.Namespace(sNewName & "\").CopyHere _
oApp.Namespace(sNewName & ".zip").Items, lCopyHereParams
End If
'let us know we're done
Application.StatusBar = "Done creating resoures folder"
l_exit:
'garbage collection
On Error Resume Next
Kill sNewName & ".zip"
Set oFSO = Nothing
Set oFile = Nothing
Application.ScreenUpdating = True
Exit Function
l_err:
fCreateResourcesFolder = -1000
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------
' Delete the passed in folder
' If parameter isn't passed, defaults to a folder named the same as this project
' in the same folder as this project
'----------------------------------------------------------------------------------------------
Public Function fDeleteResourcesFolder(Optional sFolderName As String) As Integer
Dim oFSO As Object
On Error GoTo l_err
'what am I working on?
If sFolderName = "" Then
sFolderName = fGetResourcesFolderPath(False) & "\"
sFolderName = sFolderName & Left(ThisDocument.Name, InStrRev(ThisDocument.Name, ".") - 1)
End If
'Now create an instance of the FileSystemObject
Set oFSO = CreateObject("Scripting.FileSystemObject")
'if we've got a slash
If Right(sFolderName, 1) = "\" Then
'get rid of it
sFolderName = Left(sFolderName, Len(sFolderName) - 1)
End If
'Attempt to delete it
On Error Resume Next
oFSO.deletefolder sFolderName
On Error GoTo l_err
l_exit:
'garbage cleanup
On Error Resume Next
Set oFSO = Nothing
Exit Function
l_err:
fDeleteResourcesFolder = -1000
Resume l_exit
End Function
'----------------------------------------------------------------------------------------------
'Callback for getImage
'Note: different process to use microsoft built-in images vs. other kinds of images
'although the code which uses the fLoadPictureGDI comes from an Excel project,
'it was modified to be able to be used in Word
'(thus the use of the object variable as an intermediary)
'----------------------------------------------------------------------------------------------
Public Sub getImage(control As IRibbonControl, ByRef ReturnedVal)
Dim sPicName As String
Dim oRet As Object
Dim sRet As String
Dim sSize As String
Dim sImagePath As String
Dim sImageExtension As String
On Error GoTo l_err
'get some defaults
sImageExtension = ".png"
'sImagePath = ThisDocument.Path & "\CustomImages\"
sImagePath = fGetResourcesFolderPath & "\"
'this should give us the name of a custom image or a builtin microsoft image
sRet = myRibbonControls(control.ID).Image
'we do different processes, if we're using a custom image
If myRibbonControls.ImageUsingCustom = True Then
'load the image
Set oRet = fLoadPictureGDI(sImagePath & sRet & sImageExtension)
'if we got nothing from our first loading attempt
If oRet Is Nothing Then
'try our default custom image, with the appropriate size
If myRibbonControls(control.ID).Size Then
sSize = "_32"
Else
sSize = "_16"
End If
'this loads the default image
Set oRet = fLoadPictureGDI(sImagePath & "JMBM" & sSize & sImageExtension)
End If
'If we were still unsuccessful, but we're looking for an image, give one
If oRet Is Nothing Then
ReturnedVal = "FileNew"
'this should be our custom image, whether the default custom or the assigned one
Else
Set ReturnedVal = oRet
End If
Else 'built-in image
If sRet = "" Then
'use a blank page as our default "image"
sRet = "ButtonTaskSelfSupport"
End If
ReturnedVal = sRet
End If
l_exit:
Exit Sub
l_err:
'if any error, just show a built-in control of the question mark variety
ReturnedVal = "ButtonTaskSelfSupport"
Resume l_exit
End Sub
'----------------------------------------------------------------------------------------------
'This module provides a LoadPictureGDI function, which can
'be used instead of VBA's LoadPicture, to load a wide variety
'of image types from disk - including png.
'
'The png format is used in Office 2007-2010 to provide images that
'include an alpha channel for each pixel's transparency
'
'Author: Stephen Bullen
'Date: 31 October, 2006
'Email: stephen@oaltd.co.uk
'Updated : 30 December, 2010
'By : Rob Bovey
'Reason : Also working now in the 64 bit version of Office 2010
'----------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------
' Procedure: LoadPictureGDI
' Purpose: Loads an image using GDI+
' Returns: The image as an IPicture Object
'----------------------------------------------------------------------------------------------
Public Function fLoadPictureGDI(ByVal sFileName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim lResult As Long
#If VBA7 Then
Dim hGdiPlus As LongPtr
Dim hGdiImage As LongPtr
Dim hBitmap As LongPtr
#Else
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
#End If
'Initialize GDI+
uGdiInput.GdiplusVersion = 1
lResult = GdiplusStartup(hGdiPlus, uGdiInput)
If lResult = 0 Then
'Load the image
lResult = GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage)
If lResult = 0 Then
'Create a bitmap handle from the GDI image
lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)
'Create the IPicture object from the bitmap handle
Set fLoadPictureGDI = fCreateIPicture(hBitmap)
'Tidy up
GdipDisposeImage hGdiImage
End If
'Shutdown GDI+
GdiplusShutdown hGdiPlus
End If
End Function
'----------------------------------------------------------------------------------------------
' Procedure: CreateIPicture
' Purpose: Converts a image handle into an IPicture object.
' Returns: The IPicture object
'----------------------------------------------------------------------------------------------
#If VBA7 Then
Private Function fCreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function fCreateIPicture(ByVal hPic As Long) As IPicture
#End If
Dim lResult As Long
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
' Create the Picture object.
lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' Return the new Picture object.
Set fCreateIPicture = IPic
End Function