I have created a custom page size for excel under "windows print server properties". following the steps given here https://www.win2pdf.com/doc/pdf-custom-paper-windows-10.html
Now I have all the custom sizes including default sizes shown in the excel page size list. next, I have pulled all sizes to excel Combobox dropdown with the following codes.
so my requirement is to change excel sheet size with Combobox selection change.
Please Note: we cannot change size with case method or predefine it unless sizes are fixed, as sizes will be dynamic in Combobox, once the user creates a new size it ll get added to Combobox.
Thanks
'worksheet code
ActiveSheet.ComboBox1.List = GetPaperSizes
'module code
Option Explicit
Private Const DC_PAPERNAMES = &H10
Private Declare Function DeviceCapabilities _
Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" _
(ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
ByRef lpOutput As Any, _
ByRef lpDevMode As Any) _
As Long
Private Declare Function StrLen _
Lib "kernel32.dll" _
Alias "lstrlenA" _
(ByVal lpString As String) _
As Long
Function GetPaperSizes() As Variant
Dim AllNames As String
Dim I As Long
Dim Msg As String
Dim PD As Variant
Dim Ret As Long
Dim papersizes() As Byte
Dim PaperSize As String
'Retrieve the number of available paper names
PD = Split(Application.ActivePrinter, " on ")'<<<== change "on" with its local Language translation from english
Ret = DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, ByVal 0&, ByVal 0&)
'resize the array
ReDim papersizes(0 To Ret * 64) As Byte
'retrieve all the available paper names
Call DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, papersizes(0), ByVal 0&)
'convert the retrieved byte array to an ANSI string
AllNames = StrConv(papersizes, vbUnicode)
'loop through the string and search for the names of the papers
For I = 1 To Len(AllNames) Step 64
PaperSize = Mid(AllNames, I, 64)
PaperSize = Left(PaperSize, StrLen(PaperSize))
If PaperSize <> vbNullString Then Msg = Msg & PaperSize & vbCrLf
Next I
GetPaperSizes = Split(Left(Msg, Len(Msg) - 2), vbCrLf)
End Function
can I expect any help on this? I am not sure this bump is right or not.
Related
I'm creating a userform for users in my department that will allow them to select files/subfolders from templates to create a working folder. This is done using VBA7 through Excel 2010 (the only tool available for this department...) on a Windows 10 Enterprise 64-bit desktop. Bare bones, it works great. I've even used other API functions successfully to make the Excel userform appear to the user like it's own standalone application. Now I'm just trying to add some file icons to make it a little easier (and prettier) for the users to visualize.
The logic of adding the icons during userform initialization boils down to:
1) Populate a dictionary of file template source paths at run time
2) Populate a TreeView with nodes that represent the files by using this dictionary
3) Use the same file paths in the dictionary to assign icons to each node by using API functions to extract icons from the files
I've browsed a lot of forums and code databases on using API functions to extract icons from files and converting them somehow into a usable image for the userform controls. I've experimented with several functions and constant values and combinations of each. But I hit a wall months ago, and I've routinely been banging my head against it with no progress.
Below is the relevant code from an API module I've set up in the workbook, cut down to the be easily copied into a new module, in a new workbook, with a fresh userform module that contains only a new TreeView control. It's pretty much copypasta from forums and heavily annotated for my own sake. The comments should also explain my reasoning, which might be incorrect. Finally, I've also noted ('NOTE - ...) issues and variations to the code in some comments.
Option Explicit
'Function GetFileIcon constants and variables
'Constants define values in UDT and enum variables
'Variables used in function parameters and declared function SHGetFileInfo,
' which is called by GetFileIcon
Private Const MAX_PATH As Long = 260
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_SMALLICON As Long = &H1
Private Const SHGFI_LARGEICON As Long = &H0
'Structure that contains file info
Private Type SHFILEINFO
'Handle to the file icon
hIcon As Long
'Icon image index within system image list
iIcon As Long
'Flag for one or more file attribute
dwAttributes As Long
'Path and file name as it appears in the Windows shell
szDisplayName As String * MAX_PATH
'File type description
szTypeName As String * 80
End Type
'Icon size in pixels
Public Enum isccIconSizeConst
'32x32 icon
isccLargeIcon = SHGFI_LARGEICON
'16x16 icon
isccSmallIcon = SHGFI_SMALLICON
End Enum
'Icon type, seems to be defined by usage
Public Enum itccIconTypeConst
'Normal icon, unclear how normal is defined
itccNormalIcon = SHGFI_ICON
End Enum
'UDT that stores a Globally Unique IDentifier (GUID), a 128-bit integer
' used to identify resources
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Conditional compilation of API declared functions, evaluating
' Version of VBA installed (VBA7 or VBA6) and
' Windows system type (64- or 32-bit environment)
'Compatibility of long variable type (Long vs LongPtr), library file,
' and alias within the library file vary with VBA version and Windows
' system type
#If VBA7 Then
'UDT that stores bitmap info
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
'Long variable type of some elements varies depending VBA version
Private Type uPicDesc
cbSize As Long 'Size of structure
picType As Long 'Type of picture
hImage As LongPtr 'Handle to image
hPal As LongPtr 'Handle to palette
End Type
#If Win64 Then 'also VBA7
'Convert a handle into an Object Linking and Embedding (OLE)
' IPicture interface object
'IPicture parameter type is an interface that manages a picture
' object and its properties
'Called by IconToPicture
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
#Else 'Win32 and VBA7
'See previous instance of function for description
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
'NOTE - assuming that "oleaut32.dll" is the only option available for Win32
'This shouldn't be a factor currently since the machine used runs Win64
#End If 'the following are Win32 or Win64 but still VBA7
'Get the handle of an icon from an executable file (EXE),
' dynamic-link library (DLL), or icon file (ICO)
Private Declare PtrSafe Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As LongPtr, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As LongPtr
'Get info about an object in the file system (e.g. file, folder,
' directory, drive root)
'Description of parameters
' spszPath, string that contains file path and name,
' absolute or relative
' dwFileAttributes, flags that represent what file info to assume
' psfi, SHFILEINFO structure that contains file info
' cbFileInfo, file size in bytes of the SHFILEINFO structure
' uFlags, flags that represent what file info to retrieve
'To get info from existing file system object
' pszPath must be a valid path or name
' dwFileAttributes value is ignored, set to 0
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags should be variable with flags added via
' bitwise operation
'To get info from file type/extension in general
' pszPath can be just the file extension
' dwFileAttributes must include FILE_ATTRIBUTE_NORMAL
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags must include SHGFI_USEFILEATTRIBUTES, along with flags
' that represent what file info to retrieve
'Microsoft suggests that, if this function returns an icon
' handle, freeing system memory after with DestroyIcon function
'Called by GetFileIcon
Private Declare PtrSafe Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As LongPtr, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As LongPtr, _
ByVal uFlags As LongPtr _
) As LongPtr
#Else 'VBA6 or earlier, either Win32 or Win64
'See previous instance of UDT for description
Private Type uPicDesc
cbSize As Long
picType As Long
hImage As Long
hPal As Long
End Type
'See previous instance of function for description
Private Declare Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As Long
'See previous instance of function for description
Private Declare Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As Long) _
As Long
'See previous instance of function for description
Private Declare Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) _
As Long
#End If
Public Sub TestPopulateTreeView(ByRef rtvwView As MSComctlLib.TreeView)
'Set TreeView nodes and node properties
'Called by UserForm_Initialize event
'Assume simple UserForm with single TreeView control
'Arguments for TreeView.Nodes.Add:
'Relative
'String that matches the key of the parent
'Relationship
'tvwFirst , tvwLast, tvwNext, tvwPrevious, tvwChild
'If tvwChild, then Relative is required
'key
'Unique string
'Text
'String to be displayed in the tree
'Image
'Index in an ImageList control, shown by default
'SelectedImage
'Index in an ImageList control, shown when selected
Dim varKey As Variant
Dim imlTvw As MSComctlLib.ImageList
Set imlTvw = New MSComctlLib.ImageList
'Set TreeView properties
With rtvwView
'Clear the TreeView of existing nodes
.Nodes.Clear
'Turn on checkboxes so user can select options
.CheckBoxes = True
'Set the behavior of the branch lines
'Tree lines disables any collapsing of the tree
'Root lines allow the tree to be collapsed at root level
.LineStyle = tvwTreeLines
'Set style of branch lines to exclude minimize and maximize buttons
.Style = tvwTreelinesText
'Set the behavior of the node text
'Manual prevents user from editing the text in the tree
'Automatic allows user to edit the text in the tree
.LabelEdit = tvwManual
End With
'Build ImageList of icons for use in the TreeView
With imlTvw.ListImages
'Extract the icon from a simple MS Word document
.Add 1, "test1", _
GetFileIcon("C:\Temp\New Microsoft Word Document.docx")
'NOTE - after this line, values for imlTvw.ListImages.Item(1).Picture from
'the variable Watch window are:
' Handle = 10-digit integer
' varies as I experiment with source files, which is expected
' Height = 423
' I assumed this would be 16, given that the
' GetFileIcon iscIconSize = isccSmallIcon = 16
' hPal = <Automation error>
' that "value" is what the Watch window reports verbatim
' I strongly suspect this is what's causing the issue
' Type = 3
' I honestly don't know if this is correct, but the one site that
' addressed it has named the constant vbPicTypeIcon, seemed relevant
' Width = 423
' same thing as Height, I assumed this would be 16
End With
'Set ImageList to TreeView
Set rtvwView.ImageList = imlTvw
'Populate node(s) in TreeView
With rtvwView
'Create node with no parent, added to root level
.Nodes.Add _
Relationship:=tvwNext, _
key:="node1"
'Set node default properties
With .Nodes("node1")
.Checked = True
.Text = "node1"
.Expanded = True
.Image = 1
'NOTE - there is no error after setting the .Image property, but once the
'UserForm is loaded, there is no icon image displayed in the TreeView
End With
End With
End Sub
Public Function GetFileIcon( _
ByVal strPath As String, _
Optional ByVal iscIconSize As isccIconSizeConst = isccSmallIcon, _
Optional ByVal itcIconType As itccIconTypeConst = itccNormalIcon) _
As IPicture
'Retrieve the icon associated to a file/folder
'Return the description of the specified file/folder
'For example "Folder", "Executable File", "Bmp Image", etc
'Uses the IconToPicture function
'NOTE - also tried StdPicture and IPictureDisp types
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Dim sfiInfo As SHFILEINFO
Dim lngIconType As Long
'Set the icon flag to include size and normal type
'Overrides any other type accidentally passed to function when called
If itcIconType = itccNormalIcon Then
lngIconType = iscIconSize Or itcIconType
Else
lngIconType = iscIconSize Or itccNormalIcon
End If
'Retrieve the file's icon handle
Call SHGetFileInfo(strPath, 0, sfiInfo, LenB(sfiInfo), lngIconType)
'NOTE - also tried retrieving from the general file type/extension
'defined by the system:
' Call SHGetFileInfo(strPath, FILE_ATTRIBUTE_NORMAL, sfiInfo, LenB(sfiInfo), _
' SHGFI_USEFILEATTRIBUTES Or lngIconType)
' 'Convert the icon handle to a picture object
Set GetFileIcon = IconToPicture(sfiInfo.hIcon)
'TESTING, trying out extracticon to see if that has better luck
'NOTE - also tried replacing the code above with an alternative method,
'retrieving an icon from an executable using another API function:
'
' Dim lngIcon As Long
'
' 'Retrieve icon handle from an executable
' lngIcon = ExtractIcon(0, "xwizard.exe", 0)
'
' 'Convert the icon handle to a picture object
' Set GetFileIcon = IconToPicture(lngIcon)
End Function
Public Function IconToPicture( _
hIcon As Long) _
As IPicture
'Convert an icon handle into a picture object
'Constant sourced on 2019-11-22 from
'https://stackoverflow.com/questions/1507385
' /how-do-i-convert-a-stdole-stdpicture-to-a-different-type
Const vbPicTypeIcon As Long = 3
Dim pic As uPicDesc
Dim IID_IDispatch As GUID
Dim ipdIcon As IPicture
Dim lngResult As Long
'Initialize the uPicDesc structure
With pic
.cbSize = LenB(pic)
.picType = vbPicTypeIcon
.hImage = hIcon
'NOTE - hPal is not set and defaults to 0
End With
'Create the interface GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'NOTE - this is the most common GUID I've found across forums
'I have also encountered and tried the following one, sourced from
'http://www.vbforums.com/showthread.php
' ?770797-How-do-I-use-OleCreatePictureIndirect
' 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
'Create the picture and return an object reference as the function result
lngResult = OleCreatePictureIndirect(pic, IID_IDispatch, True, ipdIcon)
'Confirm that the image was captured before setting function to picture
If lngResult = 0 Then
Set IconToPicture = ipdIcon
End If
'NOTE - assuming that 0 means successful
'found return value names (but no numeric values) listed at
'http://allapi.mentalis.org/apilist/OleCreatePictureIndirect.shtml
End Function
This whole icon thing isn't even a priority. The image icons are, and always were, a "nice to have." But it's been so long and I've spent so much effort trying to figure it out that it's now a vendetta. I'm desperate to know what is wrong in my code for the sake of my sanity; it's become my white whale...
To see the icons, chanage this line
.Style = tvwTreelinesText
To this one:
.Style = tvwTreelinesPictureText
i am trying to get list of all available page sizes in combobox as dropdown with vba. when user select the size, i need to change the worksheet size accordingly. also in another combobox i need to populate width and height of that paper size when page size in combobox is selected.
I tried something like.
Dim i As integer
for i = 1 to 30
activesheet.combobox1.value = Activesheet.PageSetup.Papersize(i)
next i
Thanks
here's a solution based on This link
ActiveSheet.ComboBox1.List = GetPaperSizes
where GetPaperSizes is the following function you must place in a standard module:
Option Explicit
'Written: June 14, 2010
'Author: Leith Ross
'Summary: Lists the supported paper sizes for the default printer in a message box.
Private Const DC_PAPERNAMES = &H10
Private Declare Function DeviceCapabilities _
Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" _
(ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
ByRef lpOutput As Any, _
ByRef lpDevMode As Any) _
As Long
Private Declare Function StrLen _
Lib "kernel32.dll" _
Alias "lstrlenA" _
(ByVal lpString As String) _
As Long
Function GetPaperSizes() As Variant
Dim AllNames As String
Dim I As Long
Dim Msg As String
Dim PD As Variant
Dim Ret As Long
Dim papersizes() As Byte
Dim PaperSize As String
'Retrieve the number of available paper names
PD = Split(Application.ActivePrinter, " on ")'<<<== change "on" with its local Language translation from english
Ret = DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, ByVal 0&, ByVal 0&)
'resize the array
ReDim papersizes(0 To Ret * 64) As Byte
'retrieve all the available paper names
Call DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, papersizes(0), ByVal 0&)
'convert the retrieved byte array to an ANSI string
AllNames = StrConv(papersizes, vbUnicode)
'loop through the string and search for the names of the papers
For I = 1 To Len(AllNames) Step 64
PaperSize = Mid(AllNames, I, 64)
PaperSize = Left(PaperSize, StrLen(PaperSize))
If PaperSize <> vbNullString Then Msg = Msg & PaperSize & vbCrLf
Next I
GetPaperSizes = Split(Left(Msg, Len(Msg) - 2), vbCrLf)
End Function
New in Stack Overflow, I'm building a macro in Excel with VBA. Basically I have a file with multiple tabs with information in tables, these tables have text in it and some words from that text are bold and repeat in each tab (lets say owner and process). I do display of this information in a textbox located in a form according to the line of the table they pick before on a listbox, the text displays correctly but it ignore the text formatting(bold and italic). Is there a way to display the text formatting in the textbox as it is in the table?
Hope I've have made myself clear enough.
Typical example for a Shape textbox (not ActiveX):
Sub BoxMaker()
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 217.5, 51#, _
482.25, 278.25).Select
Selection.Name = "SPLASH"
Selection.Characters.Text = "Please Wait for Macro"
With Selection.Characters(Start:=1, Length:=21).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Characters(Start:=8, Length:=4).Font.Bold = True
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
End Sub
You can format text in a textbox similar to text in a cell.
Possible work around in UserForm using a Webbrowser control
Due to your comment: "...actually I'm using MSForms.TextBox"
A possible work around would be to create a simple HTML file using the b tag (e.g. blabla within normal textbold text ...) for bold text and load it into a Webbrowser control (needs reference to Microsoft Internet Controls) e.g. via WebBrowser1.Navigate ThisWorkbook.Path & "\topic.htm".
As HTML commonly uses utf-8 encoding I demonstrate an approach using the system function WideCharToMultiByte (API call).
Example call using helper functions (API calls)
' declare and assign simple html string
Dim htmlstring as String
htmlstring = "<html><body><div>Normal text <b>bold text</b> further text</div></body></html>"
' write html file via helper procedure
writeUtf8 htmlstring, ThisWorkbook.Path & "\topic.htm"
' load html file into WebBrowswer control
Me.WebBrowser1.Navigate ThisWorkbook.Path & "\topic.htm"
Helper procedures
I suggest to write a separate code module for these helper functions:
Option Explicit ' declaration head of separate code module
' Declare API Function
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Public Sub writeUtf8(ByVal s As String, ByVal datei As String)
' Purpose: save HTML String in utf-8 mode
' Note: called by writeUtf8 htmlstring, thisworkbook.path & "\topic.htm"
Dim file As Integer
Dim B() As Byte
file = FreeFile
Open datei For Binary Access Write Lock Read Write As #file
getUtf8 s, B
Put #file, , B
Close #file
End Sub
Private Sub getUtf8(ByRef s As String, ByRef B() As Byte)
' Note: called by above helper function; uses API call (see declaration head)
Const CP_UTF8 As Long = 65001
Dim len_s As Long
Dim ptr_s As Long
Dim size As Long
Erase B
len_s = Len(s)
If len_s = 0 Then _
err.Raise 30030, , "Len(WideChars) = 0"
ptr_s = StrPtr(s)
size = WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, 0, 0, 0, 0)
If size = 0 Then _
err.Raise 30030, , "WideCharToMultiByte() = 0"
ReDim B(0 To size - 1)
If WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, VarPtr(B(0)), size, 0, 0) = 0 Then _
err.Raise 30030, , "WideCharToMultiByte(" & Format$(size) & ") = 0"
End Sub
I am developing an Excel add-in with a CHM help file. The CHM has topics that I am trying to reach from Excel's "Insert Function" dialog. This is confirmed when I invoke HH.EXE as follows:
HH.EXE -mapid 1234 "mk:#MSITSTORE:<path-to-my-chm-file>"
I registered all of my UDFs with the Application.MacroOptions( ) function, passing the appropriate parameters (Macro, Category, HelpContextID and HelpFile).
When I click the "Help on this function" link, HH.EXE is invoked with the correct path and file name of my CHM. However, there is no -mapid parameter used for the invocation of HH.EXE. Consequently, when my CHM file is loaded, HH does not go to the desired topic.
Does anyone know or have a guess as to why Excel may be omitting this parameter?
Thank you!
As I understand you want something like shown in the snapshot. Context-sensitive help is complex.
I add sample code for buttons and code for calling the HTMLHelp (CHM) API.
Office 2007 is installed on my machine only.
This is done by a HTMLHelp API call (code snippet (1)):
'******************************************************************************
'----- Modul - definition for HTMLHelp
'----- (c) Ulrich Kulle, http://www.help-info.de/en/Visual_Basic_Applications/vba.htm
'----- 2002-08-26 Version 0.2.xxx
'******************************************************************************
'----- Portions of this code courtesy of David Liske.
Declare Function IsWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As Long) As Long
Declare Function HTMLHelpTopic Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As String) As Long
Private Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, dwData As HH_FTS_QUERY) As Long
'--- to keep the handle of the HH windows when calling help by API --------
Public HHwinHwnd As Long
'--- some constants used by the API ---------------------------------------
Public Const HH_DISPLAY_TOPIC = &H0 ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = &H1 ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = &H2 ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = &H3 ' select search tab and perform a search
Public Const HH_HELP_CONTEXT = &HF ' display mapped numeric value in dwData
Public Const HH_CLOSE_ALL = &H12
Public Type HH_FTS_QUERY ' UDT for accessing the Search tab
cbStruct As Long ' Sizeof structure in bytes.
fUniCodeStrings As Long ' TRUE if all strings are unicode.
pszSearchQuery As String ' String containing the search query.
iProximity As Long ' Word proximity.
fStemmedSearch As Long ' TRUE for StemmedSearch only.
fTitleOnly As Long ' TRUE for Title search only.
fExecute As Long ' TRUE to initiate the search.
pszWindow As String ' Window to display in
End Type
Public Function HFile(ByVal i_HFile As Integer) As String
'----- Set the string variable to include the application path of helpfile
Select Case i_HFile
Case 1
HFile = ThisWorkbook.Path & "\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = ThisWorkbook.Path & "\CHM-example.chm"
End Select
End Function
Public Sub ShowContents(ByVal intHelpFile As Integer)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0)
End Sub
Public Sub ShowIndex(ByVal intHelpFile As Integer)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0)
End Sub
Public Sub ShowTopic(ByVal intHelpFile As Integer, strTopic As String)
HHwinHwnd = HTMLHelpTopic(hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, strTopic)
End Sub
Public Sub ShowTopicID(ByVal intHelpFile As Integer, IdTopic As Long)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic)
End Sub
Public Sub CloseHelp(ByVal hwnd As Long)
Const WM_CLOSE = &H10
If IsWindow(hwnd) Then
SendMessage hwnd, WM_CLOSE, 0, 0
End If
End Sub
'------------------------------------------------------------------------------
'----- display the search tab
'----- bug: start searching with a string dosn't work
'------------------------------------------------------------------------------
Public Sub ShowSearch(ByVal intHelpFile As Integer)
Dim searchIt As HH_FTS_QUERY
With searchIt
.cbStruct = Len(searchIt)
.fUniCodeStrings = 1&
.pszSearchQuery = "foobar"
.iProximity = 0&
.fStemmedSearch = 0&
.fTitleOnly = 1&
.fExecute = 1&
.pszWindow = ""
End With
Call HtmlHelpSearch(0&, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
End Sub
And some sample code (2) added:
Sub AddUDFToCategory()
'------------------------------------------------------------------------------
' insert after Description line [optional]: Category:=2, _ => Date & Time
'------------------------------------------------------------------------------
' If the UDF's are in an Addin (.xla) it's better to qualify the function name
' like this:
' Macro:=ThisWorkbook.Name & "!" & "DayName"
'------------------------------------------------------------------------------
' see also Excel help for Application.MacroOptions
'------------------------------------------------------------------------------
application.MacroOptions _
Macro:="TestMacro", _
Description:="This function gives back the 'Hello world' message!", _
Category:=2, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
HelpContextID:=10000
application.MacroOptions _
Macro:="DayName", _
Description:="A Function That Gives the Name of the Day", _
Category:=2, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
HelpContextID:=20000
End Sub
Function TestMacro()
'----------------------------------------------------------------
' Display a message box with a help button linked to a help topic
'----------------------------------------------------------------
MsgBox "The 'Hello World' message for testing this function!.", _
Buttons:=vbOKOnly + vbMsgBoxHelpButton, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
Context:=20010
End Function
Function DayName(InputDate As Date)
'---------------------------------------------
'--- A Function That Gives the Name of the Day
'--- http://www.fontstuff.com/vba/vbatut01.htm
'---------------------------------------------
Dim DayNumber As Integer
DayNumber = Weekday(InputDate, vbSunday)
Select Case DayNumber
Case 1
DayName = "Sunday"
Case 2
DayName = "Monday"
Case 3
DayName = "Tuesday"
Case 4
DayName = "Wednesday"
Case 5
DayName = "Thursday"
Case 6
DayName = "Friday"
Case 7
DayName = "Saturday"
End Select
End Function
For a working example go to Online Help and Visual Basic for Applications
please. Search for VBA - Download and the download link Download Visual Basic for Applications example project (EXCEL).
download the ZIP file from the link above to a temp directory, right click the saved ZIP file first, click Properties and click Unblock
unzip to a temp directory.
as a test open CHM file first by double click
double click CHM_VBA_example.xls
first have a look to security warnings ( Excel) and set to Activate
follow the instructions from the Excel example worksheet.
For further information read Using the VBA Excel Example File too.
With the Top and Left arguments for this function is there a Centre screen option, or will it always be a number?
I'm using this instead of a regular inputbox as it handles the cancel event better but it always appears in the bottom right of the screen which is less than helpful :/
There is no center screen option. You'd have to calculate it. But, assuming you are using Excel 2007 or later, there's another issue...
This was news to me, but in googling and testing I see that in Excel 2007 and 2010 Application.Inputbox reverts to its last position, disregarding the Top and Left settings. This problem seems to persist even if a new Inputbox is called from a new worksheet. When I try it in XL 2003 it works correctly, and the Inputbox is placed at the correct left and right coordinates.
You can maybe just drag the Inputbox where you want and then save. Unless somebody drags it later, it will re-open in the same place.
Here's a link to a solution that worked for somebody to bring back the correct behavior, and also addresses centering the inputbox. It does require API calls, so save your work before you try it.
EDIT - Per JMax's comment, here's the code from the link above. It's by a user called KoolSid on the vbforums.com site:
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" (ByVal idHook As Long, _
ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
'~~> Handle to the Hook procedure
Private hHook As Long
'~~> Hook type
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
'~~> SetWindowPos Flags
Private Const SWP_NOSIZE = &H1 '<~~ Retains the current size
Private Const SWP_NOZORDER = &H4 '<~~ Retains the current Z order
Dim InputboxTop As Long, InputboxLeft As Long
Sub TestInputBox()
Dim stringToFind As String, MiddleRow As Long, MiddleCol As Long
hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, 0, GetCurrentThreadId)
'~~> Get the center cell (keeping the excel menus in mind)
MiddleRow = ActiveWindow.VisibleRange.Rows.Count / 1.2
'~~> Get the center column
MiddleCol = ActiveWindow.VisibleRange.Columns.Count / 2
InputboxTop = Cells(MiddleRow, MiddleCol).Top
InputboxLeft = Cells(MiddleRow, MiddleCol).Left
'~~> Show the InputBox. I have just used "Sample" Change that...
stringToFind = Application.InputBox("Sample", _
"Sample", "Sample", InputboxLeft, InputboxTop, , , 2)
End Sub
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
'~~> Change position
SetWindowPos wParam, 0, InputboxLeft, InputboxTop, _
0, 0, SWP_NOSIZE + SWP_NOZORDER
'~~> Release the Hook
UnhookWindowsHookEx hHook
End If
MsgBoxHookProc = False
End Function
You can test the regular inputbox to see if cancel was pressed, and it has the extra benifit of always being centered. Just use StrPtr(variable) = 0 to test it. Simple!
Another way to avoid a user hitting OK with nothing typed is to add a default value inside the input box to start with, that way you know that if it returns an empty string, it's most likely due to the cancel button being pressed.
StrPtr will return a 0 if cancel was selected (also returns 0 for vbNullString, btw). Please note that StrPtr work in VB5, VB6, and VBA, but since it's not officially supported, it could be rendered unusuable years down the line. I highly doubt they'd get rid of it but it's worth considering if this is an application you plan to distribute.
Sub CancelTest()
Dim temp As String
temp = InputBox("Enter your name", "Cancel Test")
If StrPtr(temp) = 0 Then
' You pressed cancel
Else
If temp = "" Then
'You pressed OK but entered nothing
Else
'Do your thing
End If
End If
End Sub
Some more info on strptr:
StrPtr(S) returns a pointer to the actual string data currently stored in S. This is what you need when passing the string to Unicode API calls. The pointer you get points to the Datastring field, not the Length prefix field. In COM terminology, StrPtr returns the value of the BSTR pointer. (from the fantastic site: http://www.aivosto.com/vbtips/stringopt2.html)
' assume normal screen else go through GetDeviceCaps(hDCDesk, LOGPIXELSX) etc etc
' 1440 twips / inch pts / pix = 3/4 inch 100 pts
' so twips / pixel = 15
Sub GetRaXy(Ra As Range, X&, Y&) ' in twips
Dim ppz!
ppz = ActiveWindow.Zoom / 75 ' zoom is % so 100 * 3/4 =>75
' only the pixels of rows and columns are zoomed
X = (ActiveWindow.PointsToScreenPixelsX(0) + Ra.Left * ppz) * 15
Y = (ActiveWindow.PointsToScreenPixelsY(0) + Ra.Top * ppz) * 15
End Sub
Function InputRealVal!(Optional RaTAdd$ = "K11")
Dim IStr$, RAt As Range, X&, Y&
Set RAt = Range(RaTAdd)
GetRaXy RAt, X, Y
IStr = InputBox(" Value ", "ENTER The Value ", 25, X, Y)
If StrPtr(IStr) = 0 Then
MsgBox "Cancel Pressed"
Exit Function
End If
If IsNumeric(IStr) Then
InputRealVal = CDec(IStr)
Else
MsgBox "Bad data entry"
Exit Function
End If
End Function