A Color Picker Control for Visual Basic 6 (VB6) - vb6

I am looking for a free color picker control for Visual Basic 6. Something like this or this. Is there any?
Update. Here is what I found so far:
A Photoshop-style Color Picker
Color Picker Control with Sample Code

Have a look at: https://web.archive.org/web/20111001144343/http://www.devx.com/vb2themax/Tip/19257
It's supposed to show the standard color dialog (ChooseColor API in comdlg32.dll).
For convenience, here's the code:
Private Type ChooseColorStruct
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
(lpChoosecolor As ChooseColorStruct) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor _
As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Const CC_RGBINIT = &H1&
Private Const CC_FULLOPEN = &H2&
Private Const CC_PREVENTFULLOPEN = &H4&
Private Const CC_SHOWHELP = &H8&
Private Const CC_ENABLEHOOK = &H10&
Private Const CC_ENABLETEMPLATE = &H20&
Private Const CC_ENABLETEMPLATEHANDLE = &H40&
Private Const CC_SOLIDCOLOR = &H80&
Private Const CC_ANYCOLOR = &H100&
Private Const CLR_INVALID = &HFFFF
' Show the common dialog for choosing a color.
' Return the chosen color, or -1 if the dialog is canceled
'
' hParent is the handle of the parent form
' bFullOpen specifies whether the dialog will be open with the Full style
' (allows to choose many more colors)
' InitColor is the color initially selected when the dialog is open
' Example:
' Dim oleNewColor As OLE_COLOR
' oleNewColor = ShowColorsDialog(Me.hwnd, True, vbRed)
' If oleNewColor <> -1 Then Me.BackColor = oleNewColor
Function ShowColorDialog(Optional ByVal hParent As Long, _
Optional ByVal bFullOpen As Boolean, Optional ByVal InitColor As OLE_COLOR) _
As Long
Dim CC As ChooseColorStruct
Dim aColorRef(15) As Long
Dim lInitColor As Long
' translate the initial OLE color to a long value
If InitColor <> 0 Then
If OleTranslateColor(InitColor, 0, lInitColor) Then
lInitColor = CLR_INVALID
End If
End If
'fill the ChooseColorStruct struct
With CC
.lStructSize = Len(CC)
.hwndOwner = hParent
.lpCustColors = VarPtr(aColorRef(0))
.rgbResult = lInitColor
.flags = CC_SOLIDCOLOR Or CC_ANYCOLOR Or CC_RGBINIT Or IIf(bFullOpen, _
CC_FULLOPEN, 0)
End With
' Show the dialog
If ChooseColor(CC) Then
'if not canceled, return the color
ShowColorDialog = CC.rgbResult
Else
'else return -1
ShowColorDialog = -1
End If
End Function

There is a color-picker built into VB6. The common dialog control can be used as a color picker.
Here's the code example from the VB6 manual
Private Sub Command1_Click()
' Set Cancel to True
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
'Set the Flags property
CommonDialog1.Flags = cdlCCRGBInit
' Display the Color Dialog box
CommonDialog1.ShowColor
' Set the form's background color to selected color
Form1.BackColor = CommonDialog1.Color
Exit Sub
ErrHandler:
' User pressed the Cancel button
End Sub

Related

Visual Basic 6 - Argument not optional

I have this very simple code:
Private Sub Image87_Click()
PrintRTFWithMargins
End Sub
PrintRTFWithMargins is a function, which should "hopefully" print the contents of a RichTextBox. Every time I do run the code though, it gives me "Argument not optional" on PrintRTFWithMargins.
The code inside the function has already Option Explicit at the start, and I've tried to put it at the start of the Image87_Click too, but nothing.
Here's the code of PrintRTFWithMargins:
Option Explicit
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
Private Type FORMATRANGE
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CHARRANGE
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, _
ByVal wp As Long, lp As Any) As Long
Public Function PrintRTFWithMargins(RTFControl As Object, _
ByVal LeftMargin As Single, ByVal TopMargin As Single, _
ByVal RightMargin As Single, ByVal BottomMargin As Single) _
As Boolean
'********************************************************8
'PURPOSE: Prints Contents of RTF Control with Margins
'PARAMETERS:
'RTFControl: RichTextBox Control For Printing
'LeftMargin: Left Margin in Inches
'TopMargin: TopMargin in Inches
'RightMargin: RightMargin in Inches
'BottomMargin: BottomMargin in Inches
'***************************************************************
On Error GoTo ErrorHandler
'*************************************************************
'I DO THIS BECAUSE IT IS MY UNDERSTANDING THAT
'WHEN CALLING A SERVER DLL, YOU CAN RUN INTO
'PROBLEMS WHEN USING EARLY BINDING WHEN A PARAMETER
'IS A CONTROL OR A CUSTOM OBJECT. IF YOU JUST PLUG THIS INTO
'A FORM, YOU CAN DECLARE RTFCONTROL AS RICHTEXTBOX
'AND COMMENT OUT THE FOLLOWING LINE
If Not TypeOf RTFControl Is RichTextBox Then Exit Function
'**************************************************************
Dim lngLeftOffset As Long
Dim lngTopOffSet As Long
Dim lngLeftMargin As Long
Dim lngTopMargin As Long
Dim lngRightMargin As Long
Dim lngBottomMargin As Long
Dim typFr As FORMATRANGE
Dim rectPrintTarget As Rect
Dim rectPage As Rect
Dim lngTxtLen As Long
Dim lngPos As Long
Dim lngRet As Long
Dim iTempScaleMode As Integer
iTempScaleMode = Printer.ScaleMode
' needed to get a Printer.hDC
Printer.Print ""
Printer.ScaleMode = vbTwips
' Get the offsets to printable area in twips
lngLeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
lngTopOffSet = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
' Get Margins in Twips
lngLeftMargin = InchesToTwips(LeftMargin) - lngLeftOffset
lngTopMargin = InchesToTwips(TopMargin) - lngTopOffSet
lngRightMargin = (Printer.Width - _
InchesToTwips(RightMargin)) - lngLeftOffset
lngBottomMargin = (Printer.Height - _
InchesToTwips(BottomMargin)) - lngTopOffSet
' Set printable area rect
rectPage.Left = 0
rectPage.Top = 0
rectPage.Right = Printer.ScaleWidth
rectPage.Bottom = Printer.ScaleHeight
' Set rect in which to print, based on margins passed in
rectPrintTarget.Left = lngLeftMargin
rectPrintTarget.Top = lngTopMargin
rectPrintTarget.Right = lngRightMargin
rectPrintTarget.Bottom = lngBottomMargin
' Set up the printer for this print job
typFr.hdc = Printer.hdc 'for rendering
typFr.hdcTarget = Printer.hdc 'for formatting
typFr.rc = rectPrintTarget
typFr.rcPage = rectPage
typFr.chrg.cpMin = 0
typFr.chrg.cpMax = -1
' Get length of text in the RichTextBox Control
lngTxtLen = Len(Form1.RichTextBox1.Text)
' print page by page
Do
' Print the page by sending EM_FORMATRANGE message
'Allows you to range of text within a specific device
'here, the device is the printer, which must be specified
'as hdc and hdcTarget of the FORMATRANGE structure
lngPos = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
True, typFr)
If lngPos >= lngTxtLen Then Exit Do 'Done
typFr.chrg.cpMin = lngPos ' Starting position next page
Printer.NewPage ' go to next page
Printer.Print "" 'to get hDC again
typFr.hdc = Printer.hdc
typFr.hdcTarget = Printer.hdc
Loop
' Done
Printer.EndDoc
' This frees memory
lngRet = SendMessage(Form1.RichTextBox1.hWnd, EM_FORMATRANGE, _
False, Null)
Printer.ScaleMode = iTempScaleMode
PrintRTFWithMargins = True
Exit Function
ErrorHandler:
Err.Raise Err.Number, , Err.Description
End Function
Private Function InchesToTwips(ByVal Inches As Single) As Single
InchesToTwips = 1440 * Inches
End Function
I really, really don't know what else to put. It's such a simple code, just running a function, and yet "Argument not optional". It's single-hand the most annoying Visual Basic error I've ever experienced, because it's so dumb
'''
Call your function as:
Dim retVal as Boolean
retVal = PrintRTFWithMargins(RichTextBox1, 1.1, 1, 1, 1)

VB.net: Showing the File Properties window from a 64-bit application?

I am trying to build an application similar to the Windows File Explorer, in VB.net. I want do use the the same window that is displayed when right clicking a file in the File Explorer, clicking Properties in the meny. The thing is, this is very easy to solve, but it only works if my application is compiled as a 32-bit application, when I compile it as 64-bit, this doesn't work.
There are two kinds of answer that I would like:
The best would be to show this file Properties window from a 64-bit application.
The second best would be to create a 32-bit application as a wrapper, that just have the purpose to show the file Properties window. I was almost able to fix this, but I do not know how to trace when the OK or Cancel button is clicked.
Here below is the code I use, that works fine in 32-bit VB.net:
Private Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (ByRef SEI As SHELLEXECUTEINFO) As Integer
Private Structure SHELLEXECUTEINFO
Dim cbSize As Integer
Dim fMask As Integer
Dim hwnd As Integer
Dim lpVerb As String
Dim lpFile As String
Dim lpParameters As String
Dim lpDirectory As String
Dim nShow As Integer
Dim hInstApp As Integer
Dim lpIDList As Integer
Dim lpClass As String
Dim hkeyClass As Integer
Dim dwHotKey As Integer
Dim hIcon As Integer
Dim hProcess As Integer
End Structure
Private Const SEE_MASK_INVOKEIDLIST As Short = &HCS
Private Const SEE_MASK_NOCLOSEPROCESS As Short = &H40S
Private Const SEE_MASK_FLAG_NO_UI As Short = &H400S
Private Const SW_SHOWNORMAL As Integer = 1
Public Function ShowProps(ByVal FileName As String, ByVal OwnerhWnd As Integer) As Boolean
Dim SEI As SHELLEXECUTEINFO = Nothing
Dim r As Integer
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = FileName
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
r = ShellExecuteEX(SEI)
If r <= 0 Then
Return False
End If
Return True
End Function

How can I get any Browser's URL in VB6?

Recently, I was trying to make a program for saving all visited URLs in a text file from any browser using Visual Basic 6. I have found some codes for VB.NET, but I like programming in VB6.
VB.NET Code for getting browser URL
Option Explicit On
Imports System.Text
Imports System.Runtime.InteropServices.Marshal
Module CurrentUrl
#Region " Overview & References "
'Overview:
'Function GetCurrentUrl returns the URL of the selected browser (IE or Chrome; Firefox to be added).
'Most of the code is based on the references listed below, but this function starts with
'the browser's main window handle and returns only 1 URL.
'It also builds a simple "treeview" of the windows up to the target window's classname.
'References:
'http://www.xtremevbtalk.com/archive/index.php/t-129988.html
'http://social.msdn.microsoft.com/forums/en-us/vbgeneral/thread/321D0EAD-CD50-4517-BC43-29190542DCE0
'http://social.msdn.microsoft.com/Forums/en/vbgeneral/thread/02a67f3a-4a26-4d9a-9c67-0fdff1428a66
#End Region
#Region " Declares, Constants, and Variables"
Private Delegate Function EnumProcDelegate(ByVal hwnd As IntPtr, ByVal lParam As IntPtr) As Boolean 'Delegate added
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As EnumProcDelegate, ByVal lParam As IntPtr) As Boolean
Private Declare Auto Function GetWindowText Lib "user32" (ByVal hWnd As IntPtr, ByVal lpString As StringBuilder, ByVal nMaxCount As Integer) As Integer
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As IntPtr, ByVal wCmd As IntPtr) As IntPtr
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As IntPtr, ByVal lpClassName As String, ByVal nMaxCount As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As IntPtr, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDFIRST = 0
Private sURL As String 'String that will contain the URL
Private cbWindows As ComboBox 'Treeview"
Private sIndent As String 'Spaces
Private sBrowser As String 'Starting window (IE or Chrome)
Private sClassName As String = "Edit" 'Default
#End Region
Public Function GetCurrentUrl(ByVal hwnd As IntPtr, ByVal browser As String, ByVal classname As String, ByVal combo As ComboBox) As String
sBrowser = browser
sClassName = classname
cbWindows = combo
If cbWindows IsNot Nothing Then
If cbWindows.GetType.Name = "ComboBox" Then
cbWindows.Items.Clear()
Else
cbWindows = Nothing
End If
End If
sURL = ""
sIndent = ""
EnumWindows(AddressOf EnumProc, hwnd) 'hwnd - originally IntPtr.Zero
Return sURL
End Function
' Enumerate the windows
' Find the URL in the browser window
Private Function EnumProc(ByVal hWnd As IntPtr, ByVal lParam As IntPtr) As Boolean
Dim buf As StringBuilder = New StringBuilder(256) 'String * 1024
Dim title As String
Dim length As Integer
' Get the window's title.
length = GetWindowText(hWnd, buf, buf.Capacity)
title = Left(buf.ToString, length)
' See if the title ends with the browser name
Dim s As String = sBrowser
Dim inprivate = sBrowser & " - [InPrivate]" 'IE adds this to the window title
If title <> "" Then
If (Right(title, s.Length) = s) Or (Right(title, inprivate.Length) = inprivate) Then
' This is it. Find the URL information.
sURL = EditInfo(hWnd, cbWindows)
Return False
End If
End If
' Continue searching
Return True
End Function
' If this window is of the Edit class (IE) or Chrome_AutocompleteEditView (Google), return its contents.
' Otherwise search its children for such an object.
Private Function EditInfo(ByVal window_hwnd As IntPtr, ByRef cbWindows As ComboBox) As String
Dim txt As String = ""
Dim buf As String
Dim buflen As Integer
Dim child_hwnd As IntPtr
Dim children() As IntPtr = {}
Dim num_children As Integer
Dim i As Integer
'Get the class name.
buflen = 256
buf = Space(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left(buf, buflen)
'Add an item to the window list combo, indent as required
If cbWindows IsNot Nothing Then
cbWindows.Items.Add(sIndent & buf)
End If
' See if we found an Edit/AutocompleteEditView object.
If buf = sClassName Then
Return WindowText(window_hwnd)
End If
' It's not an Edit/AutocompleteEditView object. Search the children.
' Make a list of the child windows.
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve children(0 To num_children) 'was 1 to ..
children(num_children) = child_hwnd
child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
End While
' Get information on the child windows.
sIndent &= " "
For i = 1 To num_children
txt = EditInfo(children(i), cbWindows)
If txt <> "" Then Exit For
Next i
sIndent = Left(sIndent, sIndent.Length - 4)
Return txt
End Function
' ************************************************
' Return the text associated with the window.
' ************************************************
Private Function WindowText(ByVal window_hwnd As IntPtr) As String
Dim txtlen As Integer
Dim txt As String
txt = "" 'WindowText = ""
If window_hwnd = 0 Then Return "" 'Exit Function
'Get the size of the window text
txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
If txtlen = 0 Then Return "" 'Exit Function
'Extra for terminating char
txtlen = txtlen + 1
'Alloc memory for the buffer that recieves the text
Dim buffer As IntPtr = AllocHGlobal(txtlen)
'Send The WM_GETTEXT Message
txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, buffer) 'byval txt
'Copy the characters from the unmanaged memory to a managed string
txt = PtrToStringAnsi(buffer)
Return Left(txt, txtlen)
End Function
End Module

LoadImage PNG in excel vba form image1.picture control, black background

I have code which load png images to picture control
Option Explicit
Option Private Module
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
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 Function GdiplusShutdown Lib "GDIPlus" ( _
ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
PicDesc As PICTDESC, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
Public Function LoadImage(ByVal strFName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
uGdiInput.GdiplusVersion = 1
If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
Set LoadImage = ConvertToIPicture(hBitmap)
GdipDisposeImage hGdiImage
End If
GdiplusShutdown hGdiPlus
End If
End Function
Public Function ConvertToIPicture(ByVal hPic As Long) As IPicture
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
Const PICTYPE_BITMAP = 1
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
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set ConvertToIPicture = IPic
End Function
But png images loading with black backgrounds instead of transparent? how to fix this?
I use this function (note the function can be in a separate module):
Private Sub UserForm_Activate()
With Me.Image1
.BorderStyle = fmBorderStyleNone
.PictureSizeMode = fmPictureSizeModeZoom
.BackStyle = fmBackStyleTransparent
.Picture = LoadImage("C:\images\MinersBag.png")
End With
end sub
Public Function LoadImagePat(ByVal h$) As IPicture 'si LoadImage ne marche pas , ou ne fait pas la transparance correct :
'code by lepelletier Patrick 28/02/2016
Dim Aff As Boolean
Dim Pic As Shape
With Application
Aff = .ScreenUpdating
.ScreenUpdating = False
End With
Set Pic = ActiveSheet.Pictures.Insert(h).ShapeRange(1)
With Pic
.Copy
Set LoadImagePat = PastePicture
.Delete
End With
Set Pic = Nothing
If Aff Then Application.ScreenUpdating = True
End Function
The PastPicture routine is by Stephen Bullen and is found here (direct download link). In case of link rot, here is a copy of modPastePicture. Save it all into modPastePicture.bas, then import that file into the VBA editor.
Attribute VB_Name = "modPastePicture"
'***************************************************************************
'*
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd
'* 15 November 1998
'*
'* CONTACT: Stephen#oaltd.co.uk
'* WEB SITE: http://www.oaltd.co.uk
'*
'* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
'* This object can then be assigned to (for example) and Image control
'* on a userform. The PastePicture function takes an optional argument of
'* the picture type - xlBitmap or xlPicture.
'*
'* The code requires a reference to the "OLE Automation" type library
'*
'* he code in this module has been derived from a number of sources
'* discovered on MSDN.
'*
'* To use it, just copy this module into your project, then you can use:
'* Set Image1.Picture = PastePicture(xlPicture)
'* to paste a picture of whatever is on the clipboard into a standard image control.
'*
'* PROCEDURES:
'* PastePicture The entry point for the routine
'* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference
'* fnOLEError Get the error text for an OLE error code
'***************************************************************************
Option Explicit
Option Compare Text
''' User-Defined Types for API Calls
'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
'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'''Windows API Function Declarations
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: PastePicture
'''
''' Purpose: Get a Picture object showing whatever's on the clipboard.
'''
''' Arguments: lXlPicType - The type of picture to create. Can be one of:
''' xlPicture to create a metafile (default)
''' xlBitmap to create a bitmap
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
''' 15 Nov 98 Stephen Bullen Updated to create our own copies of the clipboard images
'''
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
'Some pointers
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Convert the type of picture requested from the xl constant to the API constant
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(lPicType)
'Create our own copy of the image on the clipboard, in the appropriate format.
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: CreatePicture
'''
''' Purpose: Converts a image (and palette) handle into a Picture object.
'''
''' Requires a reference to the "OLE Automation" type library
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
'''
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
' 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) ' Length of structure.
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
End With
' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
' Return the new Picture object.
Set CreatePicture = IPic
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Subroutine: fnOLEError
'''
''' Purpose: Gets the message text for standard OLE errors
'''
''' Arguments: None
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 30 Oct 98 Stephen Bullen Created
'''
Private Function fnOLEError(lErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select
End Function
Why not use Insert/Picture which accepts png files? You can still assign a macro to it.
AFAIK only png files support transparent backgrounds.
If it's for a userform, I don't know of anything you can add that supports transparent objects. However your background should be static so you can fake it.
Perhaps you could just match the color behind the image? You can get the color code from your form properties.
If it's a static background but not a single color, you could take a screen shot and clip the portion you want as background for the image, layer the 2 images together in a photo editor then output as bmp which will flatten the two layers as one. There are free photo editors that can do this.

How to change the location of a .chm file at runtime

I have a .CHM Help file for my VB6 App. I need to change the location, at run time from the help file location specified in the project properties. I DO NOT want to use some form of HTML help. I just need to know how to change the location that the program looks to find the .CHM help file.
Anybody run into this issue?
I want to store the help file on the Server with the data files, not on individual machines running the application.
Set the HelpFile attribute of the App object as below:
App.HelpFile = g_Path_to_Your_CHM & "\YourHelpFile.chm"
Please note there are some security problems with CHM on a Server!
In addition to rags answer above you may want to call the help file like this:
Public Sub ShowContents(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
End Sub
It's called by :
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 = App.Path & "\help\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = App.Path & "\help\CHM-other-language.chm"
End Select
End Function
All this is added by a module:
'******************************************************************************
'----- Modul - definition for HTMLHelp - (c) Ulrich Kulle, www.help-info.de
'----- 2002-08-26 Version 1.0 first release
'----- 2005-07-17 Version 1.1 updated for Pop-Up help
'******************************************************************************
'----- Portions of this code courtesy of David Liske.
'----- Thanks to David Liske, Don Lammers, Matthew Brown and Thomas Schulz
'------------------------------------------------------------------------------
Type HH_IDPAIR
dwControlId As Long
dwTopicId As Long
End Type
'This array should contain the number of controls that have
'context-sensitive help, plus one more for a zero-terminating
'pair.
Public ids(2) As HH_IDPAIR
Declare Function GetDlgCtrlID Lib "user32" _
(ByVal hwnd As Long) As Long
Public 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
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
Private Const HH_SET_WIN_TYPE = &H4
Private Const HH_GET_WIN_TYPE = &H5
Private Const HH_GET_WIN_HANDLE = &H6
Private Const HH_DISPLAY_TEXT_POPUP = &HE ' Display string resource ID or
Public Const HH_HELP_CONTEXT = &HF ' display mapped numeric value in dwData
Private Const HH_TP_HELP_CONTEXTMENU = &H10 ' Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Private Const HH_TP_HELP_WM_HELP = &H11 ' text pop-up help, similar to WinHelp's HELP_WM_HELP.
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 = App.Path & "\help\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = App.Path & "\help\CHM-other-language.chm"
End Select
End Function
Public Sub ShowContents(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0
End Sub
Public Sub ShowIndex(ByVal intHelpFile As Integer)
HtmlHelp hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0
End Sub
Public Sub ShowTopic(ByVal intHelpFile As Integer, strTopic As String)
HTMLHelpTopic hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, strTopic
End Sub
Public Sub ShowTopicID(ByVal intHelpFile As Integer, IdTopic As Long)
HtmlHelp hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic
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

Resources