VBA Application.Printers does not work in Excel 2013 - vba

I have a vba form in Excel which puts the available printers into a combo box but the Printers object does not appear to be available. Are there any references I need to add?
Private Sub PrintForm_Initialize()
For Each ptr In Application.printers
With Me.cboPrinters
.AddItem ptr.DeviceName
.List(.ListCount - 1, 1) = ptr.DriverName
End With
Next ptr
Me.cboPrinters.Value = cboPrinters.List(0)
End Sub

I found this solution to obtain the printers;
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modListPrinters
' By Chip Pearson, chip#cpearson.com www.cpearson.com
' Created 22-Sept-2012
' This provides a function named GetPrinterFullNames that
' returns a String array, each element of which is the name
' of a printer installed on the machine.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234
Private Declare Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal HKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" ( _
ByVal HKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Byte, _
lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As Long
Public Function GetPrinterFullNames() As String()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetPrinterFullNames
' By Chip Pearson, chip#cpearson.com, www.cpearson.com
' Returns an array of printer names, where each printer name
' is the device name followed by the port name. The value can
' be used to assign a printer to the ActivePrinter property of
' the Application object. Note that setting the ActivePrinter
' changes the default printer for Excel but does not change
' the Windows default printer.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
Dim HKey As Long ' registry key handle
Dim Res As Long ' result of API calls
Dim Ndx As Long ' index for RegEnumValue
Dim ValueName As String ' name of each value in the printer key
Dim ValueNameLen As Long ' length of ValueName
Dim DataType As Long ' registry value data type
Dim ValueValue() As Byte ' byte array of registry value value
Dim ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index
' registry key in HCKU listing printers
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)
' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function

Related

Parse Backwards in VBA for a Valid Function Name

Update
This excel-names project is contained in VBA, and it might offer some insights on the validity of various names in Excel and VBA. Unfortunately, it cannot fully guarantee validity here:
Names_IsValidName(sNameToTest As String) As Boolean
Check if the name is valid:
true: Excel name is probably valid
false: Excel name is for sure not valid
Additionally, the XLParser project in C# specifies here many of the special operators and characters in Excel formulae.
However, I am still trying to determine exactly how these might apply to my solution, which must be contained in VBA.
Background
I am writing in VBA a lightweight parser for Excel formulae, which assumes that any input is syntactically valid (as validated by Excel). My goal is to properly pinpoint an entire function call within a formula.
For this, I need a function FindValidName(). This function accepts a String ending at the open parenthesis (() of a function call, and searches backward to locate the beginning of the valid formula name; or it returns -1 if no such name is found.
Question
What are the syntactic criteria for a valid function name, accessible in an Excel formula? This does not encompass every function like VBA.Mid() accessible in VBA, since those are not accessible in Excel itself. Neither does it encompass user-defined functions (UDFs) in VBA, which are accessible in Excel and have their nomenclature defined here.
More generally, how might one algorithmize in VBA a backwards search by FindValidName() from the end of the name? Mind you, this must encompass 𝑋 ∪ 𝑈, where: 𝑋 is the set of names for all native functions that could ever be accessed in an Excel formula; and 𝑈 is the set of (syntactically valid) names for all UDFs that could ever be defined in VBA and accessed in Excel.
Note
We can assume that the formula is syntactically valid. So if we encounter (searching "backwards" from right to left) a character like + that is illegal (?) for a function name, we know that this is not simply a typo. Rather, we know that any name must start to the right of ("before") that +
= A1+SUM(B1,C1)
|<-|
and if there are no characters "before" the +, then the ( is simply a grouping operation:
= A1+(B1*C1)
|
What I Have
Given the below formula extracted as a String via .Formula, I can already pinpoint where a call begins.
= A1 & CONCAT(B1, C1)
^ ^
14 21
I have already generalized this to FindFormulaCall(fml, [n]), which can locate the nth call (here the 2nd) in an arbitrarily complex formula (below).
= SUM(ABS(A1:A5)) + ABS(My_Table[#[Column Name With Punctuation: ", '#, (, ), '[, and '].]]) + ABS(B1)
^ ^
24 92
What I Need
Now I need FindValidName("= A1 & CONCAT") to "search backwards" until the start of "CONCAT"
= A1 & CONCAT(B1, C1)
|<----|
6
and return the Long number of characters (measured from the end) at which that start occurs: here 6. Alternatively, it should return -1 if no valid name is encountered.
Examples
For FindValidName("= A1 & CONCAT") the result should be 6:
= A1 & CONCAT(B1, C1)
|<----|
6
For FindValidName("= A1+SUM(B1)+ABS") the result should be 3:
= A1+SUM(B1)+ABS(C1)
|<-|
3
For FindValidName("= A1*SUM(B1)*") the result should be -1 for no valid name:
= A1*SUM(B1)*(C1 + D1)
|
I don't know if the two code samples below are of any use to you. I wrote them some time ago for a teacher friend who was trying to show how Excel worked.
The first parses the formula of a cell into their individual formulas and shows how each formula resolves to the next.
The second gets a list of every formula available in a particular workbook.
Formula Parser
For the first, you'll need two helper classes, called clsParenthetical
Option Explicit
Public IsFormula As Boolean
Public FormulaName As String
Public Expression As String
Public Result As Variant
Public Index As Long
and clsParsedFormula
Option Explicit
Public KeyText As String
Public Perentheticals As Collection
Then, the main class, called clsFormulaHelper, is this:
Option Explicit
'===========================================================================
'DECLARATIONS
'===========================================================================
'---------------------------------------------------------------------------
'region PRIVATE TYPES
Private Type Points
IsValid As Boolean
OpenAt As Long
CloseAt As Long
End Type
Private Type ExprKVP
Index As Long
Value As String
End Type
'end region PRIVATE TYPES
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'region PRIVATE CONSTANTS
Private Const ARITHMETIC_OPR_TAG As String = "Arith"
Private Const COMPARISON_OPR_TAG As String = "Comp"
Private Const TEXT_OPR_TAG As String = "Text"
Private Const REFERENCE_OPR_TAG As String = "Ref"
'end region PRIVATE CONSTANTS
'---------------------------------------------------------------------------
'---------------------------------------------------------------------------
'region MODULE-LEVEL VARIABLES
Private mOperators As Collection
Private mRngOperators As Variant
'end region MODULE-LEVEL VARIABLES
'---------------------------------------------------------------------------
'===========================================================================
'METHODS
'===========================================================================
Public Function ParseFormula(rng As Range) As clsParsedFormula
Const ARRAY_INC As Long = 100
Dim pts As Points
Dim quotes() As ExprKVP
Dim parenthetical As clsParenthetical, p As clsParenthetical
Dim ex As String
Dim c As Long, i As Long
Dim v As Variant
'Validation check.
If rng Is Nothing Then Exit Function
If rng.Cells.Count > 1 Then Exit Function
If Not rng.HasFormula Then Exit Function
Set ParseFormula = New clsParsedFormula
With ParseFormula
.KeyText = rng.Formula
'Remove any strings from the formula
'in case target characters (eg '(' or ')')
'are contained within the strings.
ReDim quotes(ARRAY_INC)
c = -1
Do
pts = FindQuotation(.KeyText)
If pts.IsValid Then
c = c + 1
'Resize the array if limit is reached.
If c > UBound(quotes) Then
ReDim Preserve quotes(UBound(quotes) + ARRAY_INC)
End If
'Populate the quote item with the quotation
'and index value.
With quotes(c)
.Value = Mid(ParseFormula.KeyText, _
pts.OpenAt, _
pts.CloseAt - pts.OpenAt + 1)
.Index = c
End With
'Replace the quotation with the key.
.KeyText = Left(.KeyText, pts.OpenAt - 1) & _
StringKeyBuilder(c) & _
Right(.KeyText, Len(.KeyText) - pts.CloseAt)
End If
'Coninue until no further quotations found.
Loop Until Not pts.IsValid
'Reduce array to correct size.
If c = -1 Then
Erase quotes
Else
ReDim Preserve quotes(c)
End If
Set .Perentheticals = New Collection
c = -1
Do
pts = FindDeepestOpenAndClose(.KeyText)
If pts.IsValid Then
c = c + 1
ex = ExtractBackToOperator(pts.OpenAt, .KeyText)
'Populate the parenthesis item.
Set parenthetical = New clsParenthetical
With parenthetical
.Index = c
.IsFormula = Len(ex) > 0
If .IsFormula Then
.FormulaName = ex
pts.OpenAt = pts.OpenAt - Len(ex)
End If
.Expression = Mid(ParseFormula.KeyText, _
pts.OpenAt, _
pts.CloseAt - pts.OpenAt + 1)
End With
.Perentheticals.Add parenthetical, CStr(c)
'Replace the parenthesis with the key.
.KeyText = Left(.KeyText, pts.OpenAt - 1) & _
FormulaKeyBuilder(c) & _
Right(.KeyText, Len(.KeyText) - pts.CloseAt)
End If
Loop Until Not pts.IsValid
'Calculate the results.
For Each parenthetical In .Perentheticals
ex = parenthetical.Expression
pts.OpenAt = 1
pts.CloseAt = 0
'Replace the string expressions.
Do While True
pts.OpenAt = InStr(pts.OpenAt, parenthetical.Expression, "{str")
If pts.OpenAt = 0 Then Exit Do
pts.CloseAt = InStr(pts.OpenAt, parenthetical.Expression, "}")
If pts.CloseAt = 0 Then Exit Do
i = ExtractIndexFromStringExpression(parenthetical.Expression, pts)
If i >= 0 And i <= UBound(quotes) Then
ex = Replace(ex, "{str" & i & "}", quotes(i).Value)
End If
pts.OpenAt = pts.CloseAt + 1
Loop
'Replace the function expressions.
pts.OpenAt = 1
pts.CloseAt = 0
Do While True
pts.OpenAt = InStr(pts.OpenAt, parenthetical.Expression, "{f")
If pts.OpenAt = 0 Then Exit Do
pts.CloseAt = InStr(pts.OpenAt, parenthetical.Expression, "}")
If pts.CloseAt = 0 Then Exit Do
i = ExtractIndexFromFunctionExpression(parenthetical.Expression, pts)
If i > -1 Then
Set p = .Perentheticals(CStr(i))
If Not p Is Nothing Then
ex = Replace(ex, "{f" & i & "}", p.Result)
End If
End If
pts.OpenAt = pts.CloseAt + 1
Loop
parenthetical.Expression = ex
v = Evaluate(ex)
If VarType(v) = vbString Then
v = chr(34) & v & chr(34)
End If
parenthetical.Result = v
Next
End With
End Function
'===========================================================================
'PRIVATE HELPER FUNCTIONS
'===========================================================================
'---------------------------------------------------------------------------
'Purpose: Converts a Long to a string key in the format {f}.
'#i: Long to be turned into formula key.
'---------------------------------------------------------------------------
Private Function FormulaKeyBuilder(i As Long) As String
FormulaKeyBuilder = "{f" & i & "}"
End Function
'---------------------------------------------------------------------------
'Purpose: Converts a Long to a string key in the format {strn}.
'#i: Long to be turned into string key.
'---------------------------------------------------------------------------
Private Function StringKeyBuilder(i As Long) As String
StringKeyBuilder = "{str" & i & "}"
End Function
'---------------------------------------------------------------------------
'Purpose: Finds position of open and close inverted commas.
'#txt: string to be searched.
'Note 1: finds closest quotation to start of string.
'Returns: Points type. If unsuccessful IsValid = False.
'---------------------------------------------------------------------------
Private Function FindQuotation(txt As String) As Points
Dim openPt As Long, closePt As Long, tmp As Long
On Error GoTo EH
openPt = InStr(txt, """")
If openPt = 0 Then GoTo EH
tmp = openPt
Do While True
tmp = InStr(tmp + 1, txt, """")
If tmp = 0 Then GoTo EH
If tmp = Len(txt) Then closePt = tmp: Exit Do
If Mid(txt, tmp + 1, 1) <> """" Then closePt = tmp: Exit Do
tmp = tmp + 1
Loop
With FindQuotation
.IsValid = True
.OpenAt = openPt
.CloseAt = closePt
End With
Exit Function
EH:
FindQuotation.IsValid = False
End Function
'---------------------------------------------------------------------------
'Purpose: Finds position of open and close parenthensis at deepest level.
'#txt: string to be searched.
'Note 1: finds deepest Expr closest to start of string.
'Returns: Points type. If unsuccessful IsValid = False.
'---------------------------------------------------------------------------
Private Function FindDeepestOpenAndClose(txt As String) As Points
Dim openPt As Long, closePt As Long
On Error GoTo EH
closePt = InStr(txt, ")")
If closePt = 0 Then GoTo EH
openPt = InStrRev(txt, "(", closePt)
If openPt = 0 Then GoTo EH
With FindDeepestOpenAndClose
.IsValid = True
.OpenAt = openPt
.CloseAt = closePt
End With
Exit Function
EH:
FindDeepestOpenAndClose.IsValid = False
End Function
'---------------------------------------------------------------------------
'Purpose: Determines if char is any Excel operator.
'#char: Character to be evaluated.
'Returns: True if successful.
'---------------------------------------------------------------------------
Private Function IsOperator(char As String, _
Optional arithOpr As Boolean = True, _
Optional compOpr As Boolean = True, _
Optional textOpr As Boolean = True, _
Optional refOpr As Boolean = True) As Boolean
Dim exists As Boolean
Dim opr As Collection
On Error Resume Next
If arithOpr Then
Set opr = mOperators(ARITHMETIC_OPR_TAG)
If Not opr Is Nothing Then
exists = opr(char)
If exists Then
IsOperator = True
Exit Function
End If
End If
End If
If compOpr Then
Set opr = mOperators(COMPARISON_OPR_TAG)
If Not opr Is Nothing Then
exists = opr(char)
If exists Then
IsOperator = True
Exit Function
End If
End If
End If
If textOpr Then
Set opr = mOperators(TEXT_OPR_TAG)
If Not opr Is Nothing Then
exists = opr(char)
If exists Then
IsOperator = True
Exit Function
End If
End If
End If
If refOpr Then
Set opr = mOperators(REFERENCE_OPR_TAG)
If Not opr Is Nothing Then
exists = opr(char)
If exists Then
IsOperator = True
Exit Function
End If
End If
End If
End Function
'---------------------------------------------------------------------------
'Purpose: Extracts string from a nominated position backwards as far as
' any operator or start of string.
'#pt: position in string to commence extraction.
'#str: string for extraction.
'Note 1: Target string length must be greater than 1.
'Returns: Extracted text or null string if no operator is found.
'---------------------------------------------------------------------------
Private Function ExtractBackToOperator(pt As Long, str As String) As String
Dim i As Long
Dim chr As String
If pt < 2 Then Exit Function
For i = pt - 1 To 1 Step -1
chr = Mid(str, i, 1)
If IsOperator(chr) Then
ExtractBackToOperator = Mid(str, i + 1, pt - (i + 1))
Exit Function
End If
Next
End Function
'---------------------------------------------------------------------------
'Purpose: Extracts index number from function expression.
'#expr: Target expression.
'#pts: start and end point of function.
'Returns: Index number or -1 of failed.
'---------------------------------------------------------------------------
Private Function ExtractIndexFromFunctionExpression(expr As String, pts As Points) As Long
On Error GoTo EH
ExtractIndexFromFunctionExpression = Mid(expr, pts.OpenAt + 2, pts.CloseAt - pts.OpenAt - 2)
Exit Function
EH:
ExtractIndexFromFunctionExpression = -1
End Function
'---------------------------------------------------------------------------
'Purpose: Extracts index number from string expression.
'#expr: Target expression.
'#pts: start and end point of function.
'Returns: Index number or -1 of failed.
'---------------------------------------------------------------------------
Private Function ExtractIndexFromStringExpression(expr As String, pts As Points) As Long
On Error GoTo EH
ExtractIndexFromStringExpression = Mid(expr, pts.OpenAt + 4, pts.CloseAt - pts.OpenAt - 4)
Exit Function
EH:
ExtractIndexFromStringExpression = -1
End Function
Private Sub Class_Initialize()
Dim opr As Collection
Set mOperators = New Collection
Set opr = New Collection
opr.Add True, "+"
opr.Add True, "-"
opr.Add True, "*"
opr.Add True, "/"
opr.Add True, "%"
opr.Add True, "^"
mOperators.Add opr, ARITHMETIC_OPR_TAG
Set opr = New Collection
opr.Add True, "="
opr.Add True, ">"
opr.Add True, "<"
mOperators.Add opr, COMPARISON_OPR_TAG
Set opr = New Collection
opr.Add True, "&"
mOperators.Add opr, TEXT_OPR_TAG
Set opr = New Collection
opr.Add True, ":"
opr.Add True, ","
opr.Add True, " "
mOperators.Add opr, REFERENCE_OPR_TAG
End Sub
You would call it in a module like this:
Dim helper As clsFormulaHelper
Dim parsedFormula As clsParsedFormula
Dim parenthetical As clsParenthetical
Set helper = New clsFormulaHelper
Set parsedFormula = helper.ParseFormula(Sheet1.Range("A4"))
Here are the outputs:
For formula: =IF(A1*(A1 + 'AB + CD'!A2) = 3, SUM(A1,A2,'AB + CD'!A3),
IF(A1 = 2, AVERAGE(A1:A3),"c" & COUNT(A1:A3)))
Nested index: 0, Expr: (A1 + 'AB + CD'!A2), Result: 3
Nested index: 1, Expr: SUM(A1,A2,'AB + CD'!A3), Formula: SUM, Result:
6
Nested index: 2, Expr: AVERAGE(A1:A3), Formula: AVERAGE, Result: 2
Nested index: 3, Expr: COUNT(A1:A3), Formula: COUNT, Result: 3
Nested index: 4, Expr: IF(A1 = 2, 2,"c" & 3), Formula: IF, Result:
"c3"
Nested index: 5, Expr: IF(A1*3 = 3, 6, "c3"), Formula: IF, Result: 6
Available Formulas
The second code sample gets a list of all formulas available in the workbook. It will only work on 64-bit.
Option Explicit
'---------------------------------------------------------
'Hook APIs and Constants
'---------------------------------------------------------
Private Declare PtrSafe Function SetWinEventHook _
Lib "user32" _
(ByVal eventMin As Long, _
ByVal eventMax As Long, _
ByVal hmodWinEventProc As LongPtr, _
ByVal pfnWinEventProc As LongPtr, _
ByVal idProcess As Long, _
ByVal idThread As Long, _
ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function UnhookWinEvent _
Lib "user32" _
(ByVal hWinEventHook As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentProcessId _
Lib "kernel32" () As Long
Private Declare PtrSafe Function GetWindowThreadProcessId _
Lib "user32" _
(ByVal hWnd As LongPtr, _
lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetClassName _
Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As LongPtr, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Const EVENT_OBJECT_CREATE As Long = 32768
Private Const WINEVENT_OUTOFCONTEXT As Long = 0
'---------------------------------------------------------
'Subclassing APIs and Constants
'---------------------------------------------------------
Private Declare PtrSafe Function SetWindowLongPtr _
Lib "user32" Alias "SetWindowLongPtrA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function CallWindowProc _
Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As LongPtr, _
ByVal hWnd As LongPtr, _
ByVal iMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare PtrSafe Function lstrlenW _
Lib "kernel32" _
(ByVal lpString As LongPtr) As Long
Private Const GWLP_WNDPROC As Long = (-4)
Private Const WM_NOTIFY As Long = &H4E
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETTOPINDEX As Long = (LVM_FIRST + 39)
Private Const LVM_GETSTRINGWIDTHW = (LVM_FIRST + 87)
'---------------------------------------------------------
'Timer APIs
'---------------------------------------------------------
Private Declare PtrSafe Function SetTimer _
Lib "user32" _
(ByVal hWnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib _
"user32" _
(ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Private Const LISTVIEW_NAME As String = "SysListView32"
Private Const REDUNDANT_LV_STRING As String = "W"
Private mHHook As LongPtr
Private mHListView As LongPtr
Private mPrevWndProc As LongPtr
Private mTimerId As Long
Private mFormulas As Collection
Private mHasFormulas As Boolean
Private mOldA1Value As Variant
Public Property Get GrabbedFormulas() As Collection
Set GrabbedFormulas = mFormulas
End Property
Public Property Get HasGrabbedFormulas() As Boolean
HasGrabbedFormulas = mHasFormulas
End Property
Public Sub GrabEm()
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'ONLY CALL THIS ROUTINE FROM THE WORKSHEET ITSELF.
'EITHER A SHEET BUTTON OR WORKSHEET EVENT WOULD BE OKAY.
'RUNNING FROM VBA EDITOR WILL DO SERIOUS DAMAGE TO YOUR WORK.
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim ws As Worksheet
On Error GoTo EH
'Warning
MsgBox _
"Please do not touch the keyboard or activate another window." & vbNewLine & vbNewLine & _
"We are about to grab all of the workbook formulas by simulating key strokes on this sheet. " & vbNewLine & vbNewLine & _
"This routine will take a few seconds.", _
vbOKOnly, _
"Formula Grabber"
'Initialise.
Set mFormulas = New Collection
mHasFormulas = False
Set ws = ThisWorkbook.Worksheets(1)
With ws
.Visible = xlSheetVisible
.Activate
With .Range("A1")
mOldA1Value = .Value
.Select
End With
End With
'First task is to find the SysListView32 handle.
'We'll hook a EVENT_OBJECT_CREATE win event, which
'we can 'coerce' by entering "=a" in a cell.
If mHHook <> 0 Then DetachHook
mHHook = SetWinEventHook(EVENT_OBJECT_CREATE, _
EVENT_OBJECT_CREATE, _
0, _
AddressOf WinEventProc, _
0, _
0, _
WINEVENT_OUTOFCONTEXT)
RunKeySequence Asc("a")
Do While Not mHasFormulas
DoEvents
Loop
EH:
ws.Range("A1").Value = mOldA1Value
ReleaseAll
End Sub
Private Function WinEventProc(ByVal hWinEventHook As LongPtr, _
WinEvent As Long, _
ByVal hWnd As LongPtr, _
ByVal idObject As Long, _
ByVal idChild As Long, _
ByVal idEventThread As Long, _
ByVal dwmsEventTime As Long) As Long
On Error GoTo EH
'We don't want to handle or subclass a window created by a different process.
If Not IsSameProcess(hWnd) Then Exit Function
'Disregard any class that isn't a SysListView32.
If Not IsListView(hWnd) Then Exit Function
'We have the handle, so now we can release the hook
'and create a subclass.
'Note: store the handle for emergency hook destruction.
mHListView = hWnd
DetachHook
mPrevWndProc = SetWindowLongPtr(mHListView, _
GWLP_WNDPROC, _
AddressOf SubbedWndProc)
Exit Function
EH:
End Function
Private Function SubbedWndProc(ByVal hWnd As LongPtr, _
ByVal iMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Dim str As String
On Error Resume Next
'The two messages we're interested in are:
'1. LVM_GETSTRINGWIDTHW which is sent
' for each item to size the window.
'2. LVM_GETTOPINDEX which is sent once
' all strings are measured.
Select Case iMsg
Case LVM_GETSTRINGWIDTHW
'A pointer to the string is passed in lParam.
str = PointerToString(lParam)
If str <> REDUNDANT_LV_STRING Then
mFormulas.Add str, str
End If
Case LVM_GETTOPINDEX
'We're ready to move on to next keystroke.
RunKeySequence
End Select
'We're not overriding anything, so pass all messages
'to previous window procedure.
SubbedWndProc = CallWindowProc(mPrevWndProc, _
hWnd, _
iMsg, _
wParam, _
lParam)
End Function
Private Sub RunKeySequence(Optional startKey As Long)
Static key As Long
On Error GoTo EH
'Pause the timer.
StopTimer
'Start the sequence.
If startKey <> 0 Then
key = startKey
Application.SendKeys "="
Application.SendKeys chr(key)
Else
key = key + 1
End If
'End the sequence.
If key < Asc("a") Or key > Asc("z") Then
'Destroy the subclass.
Unsubclass
'Clear the cell.
Application.SendKeys "{BACKSPACE}"
Application.SendKeys "{BACKSPACE}"
Application.SendKeys "{ENTER}"
mHasFormulas = True
Exit Sub
End If
'Send the next keys.
StartTimer
Application.SendKeys "{BACKSPACE}"
'Note: API timer is used in case no formulas begin with
'the entered letter (ie no message would then be
'sent to our wnd proc) so we can time out that letter.
Application.SendKeys chr(key)
Exit Sub
EH:
End Sub
Private Sub StartTimer()
On Error Resume Next
mTimerId = SetTimer(0, 0, 1000, AddressOf TimerProc)
End Sub
Private Sub StopTimer()
On Error Resume Next
KillTimer 0, mTimerId
End Sub
Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
RunKeySequence
End Sub
Private Sub DetachHook()
On Error Resume Next
UnhookWinEvent mHHook
mHHook = 0
End Sub
Private Sub Unsubclass()
On Error Resume Next
SetWindowLongPtr mHListView, GWLP_WNDPROC, mPrevWndProc
mPrevWndProc = 0
End Sub
Private Function IsSameProcess(hWnd) As Boolean
Dim windowId As Long, currentId As Long
On Error GoTo EH
GetWindowThreadProcessId hWnd, windowId
currentId = GetCurrentProcessId
IsSameProcess = (windowId = currentId)
Exit Function
EH:
End Function
Private Function IsListView(hWnd) As Boolean
Dim ret As Long
Dim str As String * 128
Dim clsName As String
On Error GoTo EH
ret = GetClassName(hWnd, str, Len(str))
clsName = Left(str, ret)
IsListView = (clsName = LISTVIEW_NAME)
Exit Function
EH:
End Function
Private Function PointerToString(psz As LongPtr) As String
Dim buffer As Long
Dim str As String
On Error GoTo EH
buffer = lstrlenW(psz) * 2
str = Space(buffer)
CopyMemory ByVal str, ByVal psz, buffer
PointerToString = Replace(str, chr(0), "")
Exit Function
EH:
End Function
Public Sub ReleaseAll()
StopTimer
Unsubclass
DetachHook
End Sub
Function nested index = 2 Expression = AVERAGE(A1:A3) Formula = AVERAGE Evaluated result = 2
Function nested index = 3 Expression = COUNT(A1:A3) Formula = COUNT Evaluated result = 3
Function nested index = 4 Expression = IF(A1 = 2, 2,"c" & 3) Formula = IF Evaluated result = "c3"
Function nested index = 5 Expression = IF(A1*3 = 3, 6, "c3") Formula = IF Evaluated result = 6
I have developed a compact suggestion in VBA, which is here awaiting review on Code Review. It should be easily repurposed into a direct solution for this question.
This suggestion is a single function NameIsValid(name), which evaluates a string and determines if it is a valid name in Excel. With appropriate safeguards in place, it does so by splicing the name into a call to LET(), which it then executes using Application.Evaluate(). An invalid name will yield an Error.
' Check if a name is valid: it may be "declared" in Excel using LET().
Public Function NameIsValid(name As String) As Boolean
' Invalidate names that are empty or too long.
If name = Empty Or VBA.Len(name) > 255 Then
NameIsValid = False
' Invalidate reserved names: "R" and "C".
ElseIf ( _
name = "C" Or name = "c" Or _
name = "R" Or name = "r" _
) Then
NameIsValid = False
' Invalidate names with external whitespace (or double spaces internally),
' which are invalid in names and yet could mesh syntactically with
' formulaic calls to LET() in Excel.
ElseIf name <> Application.WorksheetFunction.Clean(VBA.Trim(name)) Then
NameIsValid = False
' Invalidate names with injection characters, which are invalid in names
' and also disrupt formulaic calls to LET() in Excel.
ElseIf ( _
VBA.InStr(1, name, "(") Or _
VBA.InStr(1, name, ",") Or _
VBA.InStr(1, name, ";") Or _
VBA.InStr(1, name, ")") _
) Then
NameIsValid = False
' If we pass the above checks, we can safely splice the name into a
' formulaic declaration with LET() in Excel.
Else
' Get the result of formulaically declaring a name with LET() in Excel.
Dim eval As Variant
eval = Application.Evaluate("= LET(" & name & ", 0, 0)")
' Check if the declaration erred due to invalid nomenclature.
If IsError(eval) Then
NameIsValid = False
Else
NameIsValid = True
End If
End If
End Function

Save image from clipboard as .jpg and pass relative link to Access form

Using Access 365. I would like help building code to achieve the following please, I’m trying to streamline adding images to a record.
I would like to use VBA that on clicking a button will save an image as a .jpg from the clipboard (put there by User using Snip tool) to a subfolder of the database, then pass a relative link to this file to the form. I’d like to be able to attach multiple images’ links to a given record in this manner.
Using the code below (without the AltPrintScreen element) I’ve gotten as far as saving from the clipboard and generating an absolute link, but only as a .bmp. (https://www.access-programmers.co.uk/forums/threads/print-screen-into-image-file.245198/). Grateful for any help getting the rest of the way, or suggestion of an entirely different way of doing it. Cheers!
Module...
'***********************************************************************************************
' *
' * Please leave any Trademarks or Credits in place.
' *
' * ACKNOWLEDGEMENT TO CONTRIBUTORS :
' * STEPHEN BULLEN, 15 November 1998 - Original PastPicture code
' * G HUDSON, 5 April 2010 - Pause Function
' * LUTZ GENTKOW, 23 July 2011 - Alt + PrtScrn
' * PAUL FRANCIS, 11 April 2013 - Putting all pieces togeather
' *
' * DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
' * This object is then saved to a location on the disc. Please note, this
' * can also be assigned to (for example) and Image control on a userform.
' *
' * The code requires a reference to the "OLE Automation" type library.
' *
' * The code in this module has been derived from a number of sources
' * discovered on MSDN, Access World Forum, VBForums.
' *
' * To use it, just copy this module into your project, then you can use:
' * SaveClip2Bit("C:\Pics\Sample.bmp")
' * to save this to a location on the Disc.
' * (Or)
' * Set ImageControl.Image = PastePicture
' * to paste a picture of whatever is on the clipboard into a standard image control.
' *
' * PROCEDURES:
' * PastePicture : The entry point for 'Setting' the Image
' * CreatePicture : Private function to convert a bitmap or metafile handle to an OLE reference
' * fnOLEError : Get the error text for an OLE error code
' * SaveClip2Bit : The entry point for 'Saving' the Image, calls for PastePicture
' * AltPrintScreen: Performs the automation of Alt + PrtScrn, for getting the Active Window.
' * Pause : Makes the program wait, to make sure proper screen capture takes place.
'**************************************************************************************************
Option Explicit
Option Compare Text
'Declare clipboard clear
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'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
#If Win64 = 1 And VBA7 = 1 Then
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
'Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
'Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.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 PtrSafe 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 PtrSafe 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
'Uses the Keyboard simulation
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
'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 "oleaut32.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
'Uses the Keyboard simulation
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
'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
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
' Subroutine : AltPrintScreen
' Purpose : Capture the Active window, and places on the Clipboard.
Sub AltPrintScreen()
'keybd_event VK_MENU, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
'keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub
' Subroutine : PastePicture
' Purpose : Get a Picture object showing whatever's on the clipboard.
Function PastePicture() As IPicture
'Some pointers
Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Check if the clipboard contains the required format
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
'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, CF_BITMAP)
End If
End If
End Function
' Subroutine : CreatePicture
' Purpose : Converts a image (and palette) handle into a Picture object.
' NOTE : Requires a reference to the "OLE Automation" type library
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 = PICTYPE_BITMAP ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = hPal ' 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
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
' Routine : SaveClip2Bit
' Purpose : Saves Picture object to desired location.
' Arguments : Path to save the file
Public Sub SaveClip2Bit(savePath As String)
On Error GoTo errHandler:
AltPrintScreen
Pause (2)
SavePicture PastePicture, savePath
errExit:
Exit Sub
errHandler:
Debug.Print "Save Picture: (" & Err.Number & ") - " & Err.Description
Resume errExit
End Sub
' Routine : Pause
' Purpose : Gives a short intreval for proper image capture.
' Arguments : Seconds to wait.
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause
Dim PauseTime As Variant, start As Variant
PauseTime = NumberOfSeconds
start = Timer
Do While Timer < start + PauseTime
DoEvents
Loop
Exit_Pause:
Exit Function
Err_Pause:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
Resume Exit_Pause
End Function
I've created a solution that does what I want. I've used four Modules I found on various sites and then created a bit of VBA to pull the tasks together in the background.
Module 1 is the one I posted in the question above. I bypass the
AltPrintScreen part of it so it doesn't overwrite the image already in the
clipboard.
Module 2 Converts the BMP created by Modules 1 into a JPG.
Module 3 Scans a folder and populates an unbound listbox with a list
of the files found there.
Module 4 is used to make the filepaths in the listbox act as
hyperlinks to open the images on clicking.
I then created a button on a form that calls the first two Module to create a jpg from the image in the clipboard as follows...
Private Sub Command12_Click()
Dim Foldername As String
Dim FileRoot As String
Dim FilePathBMP As String
Dim FilePathJPG As String
Dim FilePathJPG2 As String
' Fist check to see if a unique folder for the open record exists, create if not
Foldername = CurrentProject.Path & "\xrays\" & Format(record_id.Value)
If Len(Dir(Foldername, vbDirectory)) = 0 Then
MkDir CurrentProject.Path & "\xrays\" & Format(record_id.Value)
End If
On Error GoTo reportErr
'The filename will begin with a date\time stamp then pull text from drop down lists the user can pick. This first creates a base filename without filtype extensions.
FileRoot = CurrentProject.Path & "\xrays\" & Format(record_id.Value) & "\" & Format(Now, "yyyymmddhhmmss") & "_" & Format(Combo14.Value) & "_" & Format(Combo21.Value)
'Creates a BMP and JPG version of the filename
FilePathBMP = FileRoot & ".bmp"
FilePathJPG = FileRoot & ".jpg"
'Save a BMP
SaveClip2Bit FilePathBMP
'Convert to JPG
WIA_ConvertImage FilePathBMP, FilePathJPG, JPEG, 85
'Delete the BMP
Kill (FilePathBMP)
Exit Sub
reportErr:
MsgBox "No image in Clipboard"
Resume Next
End Sub
On the form that will display the file list I've placed an unbound listbox "FileList". The following code calls on Module 3 and is in the OnLoad event of the form...
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
The following code is used to refresh the listbox "FileList". It can be put on an OnClick event of a button or added to the end of the above code to automatically refresh after adding a new image
Me.FileList.RowSource = ""
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
Me.FileList.Requery
Finally I put the following code in the OnDblClick event of the listbox, which calls Module 4...
Dim sPath As String
Dim sFile As String
sPath = FileList.Column(0)
' The line below extracts the filename from the full path (everything to the right of the last /)
' sFile = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
GoHyperlink (sPath)
Module 2...
Public Enum wiaFormat
BMP = 0
GIF = 1
JPEG = 2
PNG = 3
TIFF = 4
End Enum
'---------------------------------------------------------------------------------------
' Procedure : WIA_ConvertImage
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Convert an image's format using WIA
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Windows Image Acquisition (WIA)
' https://msdn.microsoft.com/en-us/library/windows/desktop/ms630368(v=vs.85).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInitialImage : Fully qualified path and filename of the original image to resize
' sOutputImage : Fully qualified path and filename of where to save the new image
' lFormat : Format to convert the image into
' lQuality : Quality level to be used for the conversion process (1-100)
'
' Usage:
' ~~~~~~
' Call WIA_ConvertImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
' "C:\Users\MyUser\Desktop\Chrysanthemum_2.jpg", _
' JPEG)
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2017-01-18 Initial Release
' 2 2018-09-20 Updated Copyright
'---------------------------------------------------------------------------------------
Public Function WIA_ConvertImage(sInitialImage As String, _
sOutputImage As String, _
lFormat As wiaFormat, _
Optional lQuality As Long = 85) As Boolean
On Error GoTo Error_Handler
Dim oWIA As Object 'WIA.ImageFile
Dim oIP As Object 'ImageProcess
Dim sFormatID As String
Dim sExt As String
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
If lQuality > 100 Then lQuality = 100
'Should check if the output file already exists and if so,
'prompt the user to overwrite it or not
Set oWIA = CreateObject("WIA.ImageFile")
Set oIP = CreateObject("WIA.ImageProcess")
oIP.Filters.Add oIP.FilterInfos("Convert").FilterID
oIP.Filters(1).Properties("FormatID") = sFormatID
oIP.Filters(1).Properties("Quality") = lQuality
oWIA.LoadFile sInitialImage
Set oWIA = oIP.Apply(oWIA)
'Overide the specified ext with the appropriate one for the choosen format
oWIA.SaveFile Left(sOutputImage, InStrRev(sOutputImage, ".")) & LCase(sExt)
WIA_ConvertImage = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oWIA Is Nothing Then Set oWIA = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_ConvertImage" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Module 3...
Option Compare Database
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
' The list box must have its Row Source Type property set to Value List.
'Method: FilDir() adds items to a collection, calling itself recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList
Debug.Print varItem
Next
Else
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
Module 4...
Option Compare Database
Option Explicit
'Purpose: Avoid warning and error messages when opening files with FollowHyperlink
'Author: Allen Browne (allen#allenbrowne.com)
'Release: 28 January 2008
'Usage: To open MyFile.doc in Word, use:
' GoHyperlink "MyFile.doc"
' instead of:
' FollowHyperlink "MyFile.doc"
'Rationale:
'FollowHyperlink has several problems:
' a) It errors if a file name contains characters such as #, %, or &.
' b) It can give unwanted warnings, e.g. on a fileame with "file:///" prefix.
' c) It yields errors if the link did not open.
'This replacement:
' a) escapes the problem characters
' b) prepends the prefix
' c) returns True if the link opened (with an optional error message if you care.)
'Limitations:
' - If a file name contains two # characters, it is treated as a hyperlink.
' - If a file name contains % followed by 2 hex digits, it assumes it is pre-escaped.
' - File name must include path.
'Documentation: http://allenbrowne.com/func-GoHyperlink.html
Public Function GoHyperlink(FullFilenameOrLink As Variant) As Boolean
On Error GoTo Err_Handler
'Purpose: Replacement for FollowHyperlink.
'Return: True if the hyperlink opened.
'Argument: varIn = the link to open
Dim strLink As String
Dim strErrMsg As String
'Skip error, null, or zero-length string.
If Not IsError(FullFilenameOrLink) Then
If FullFilenameOrLink <> vbNullString Then
strLink = PrepHyperlink(FullFilenameOrLink, strErrMsg)
If strLink <> vbNullString Then
FollowHyperlink strLink
'Return True if we got here without error.
GoHyperlink = True
End If
'Display any error message from preparing the link.
If strErrMsg <> vbNullString Then
MsgBox strErrMsg, vbExclamation, "PrepHyperlink()"
End If
End If
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "GoHyperlink()"
Resume Exit_Handler
End Function
Public Function PrepHyperlink(varIn As Variant, Optional strErrMsg As String) As Variant
On Error GoTo Err_Handler
'Purpose: Avoid errors and warnings when opening hyperlinks.
'Return: The massaged link/file name.
'Arguments: varIn = the link/file name to massage.
' strErrMsg = string to append error messages to.
'Note: Called by GoHyperlink() above.
' Can also be called directly, to prepare hyperlinks.
Dim strAddress As String 'File name or address
Dim strDisplay As String 'Display part of hyperlink (if provided)
Dim strTail As String 'Any remainding part of hyperlink after address
Dim lngPos1 As Long 'Position of character in string (and next)
Dim lngPos2 As Long
Dim bIsHyperlink As Boolean 'Flag if input is a hyperlink (not just a file name.)
Const strcDelimiter = "#" 'Delimiter character within hyperlinks.
Const strcEscChar = "%" 'Escape character for hyperlinks.
Const strcPrefix As String = "file:///" 'Hyperlink type if not supplied.
If Not IsError(varIn) Then
strAddress = Nz(varIn, vbNullString)
End If
If strAddress <> vbNullString Then
'Treat as a hyperlink if there are two or more # characters (other than together, or at the end.)
lngPos1 = InStr(strAddress, strcDelimiter)
If (lngPos1 > 0&) And (lngPos1 < Len(strAddress) - 2&) Then
lngPos2 = InStr(lngPos1 + 1&, strAddress, strcDelimiter)
End If
If lngPos2 > lngPos1 + 1& Then
bIsHyperlink = True
strTail = Mid$(strAddress, lngPos2 + 1&)
strDisplay = Left$(strAddress, lngPos1 - 1&)
strAddress = Mid$(strAddress, lngPos1 + 1&, lngPos2 - lngPos1)
End If
'Replace any % that is not immediately followed by 2 hex digits (in both display and address.)
strAddress = EscChar(strAddress, strcEscChar)
strDisplay = EscChar(strDisplay, strcEscChar)
'Replace special characters with percent sign and hex value (address only.)
strAddress = EscHex(strAddress, strcEscChar, "&", """", " ", "#", "<", ">", "|", "*", "?")
'Replace backslash with forward slash (address only.)
strAddress = Replace(strAddress, "\", "/")
'Add prefix if address doesn't have one.
If Not ((varIn Like "*://*") Or (varIn Like "mailto:*")) Then
strAddress = strcPrefix & strAddress
End If
End If
'Assign return value.
If strAddress <> vbNullString Then
If bIsHyperlink Then
PrepHyperlink = strDisplay & strcDelimiter & strAddress & strcDelimiter & strTail
Else
PrepHyperlink = strAddress
End If
Else
PrepHyperlink = Null
End If
Exit_Handler:
Exit Function
Err_Handler:
strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
Resume Exit_Handler
End Function
Private Function EscChar(ByVal strIn As String, strEscChar As String) As String
'Purpose: If the escape character is found in the string,
' escape it (unless it is followed by 2 hex digits.)
'Return: Fixed up string.
'Arguments: strIn = the string to fix up
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
Dim strOut As String 'output string.
Dim strChar As String 'character being considered.
Dim strTestHex As String '4-character string of the form &HFF.
Dim lngLen As Long 'Length of input string.
Dim i As Long 'Loop controller
Dim bReplace As Boolean 'Flag to replace character.
lngLen = Len(strIn)
If (lngLen > 0&) And (Len(strEscChar) = 1&) Then
For i = 1& To lngLen
bReplace = False
strChar = Mid(strIn, i, 1&)
If strChar = strEscChar Then
strTestHex = "&H" & Mid(strIn, i + 1&, 2&)
If Len(strTestHex) = 4& Then
If Not IsNumeric(strTestHex) Then
bReplace = True
End If
End If
End If
If bReplace Then
strOut = strOut & strEscChar & Hex(Asc(strEscChar))
Else
strOut = strOut & strChar
End If
Next
End If
If strOut <> vbNullString Then
EscChar = strOut
ElseIf lngLen > 0& Then
EscChar = strIn
End If
End Function
Private Function EscHex(ByVal strIn As String, strEscChar As String, ParamArray varChars()) As String
'Purpose: Replace any characters from the array with the escape character and their hex value.
'Return: Fixed up string.
'Arguments: strIn = string to fix up.
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
' varChars() = an array of single-character strings to replace.
Dim i As Long 'Loop controller
If (strIn <> vbNullString) And IsArray(varChars) Then
For i = LBound(varChars) To UBound(varChars)
strIn = Replace(strIn, varChars(i), strEscChar & Hex(Asc(varChars(i))))
Next
End If
EscHex = strIn
End Function
I hope all that helps others!

command print button. When I click on the print button,the first page prints twice other pages print single which is what I want

I have 2 concerns, if someone can assist. I am new to VBA. I have a command print button on my excel sheet and I added the code listed below. When I click on the print button, I have the first page print twice but the rest of the pages print single which is what I want. How do I fix the code so it only prints once.
The other thing is when the print manager window opens for me to select a printer, I would like to have the code select single page print and not duplex printing. The printer default settings are set for duplex and I dont want to change that setting through windows but for the code to automatically select single sided prints.
Thank you,
Private Sub PrintAll_Click()
Dim rngOffenders As Range
Set rngOffenders = Worksheets("Names").Range("A2", Worksheets("Names").Range("A2").End(xlDown))
Dim willPrint As Boolean
willPrint = Application.Dialogs(xlDialogPrint).Show
If Not willPrint Then Exit Sub
Dim rng As Range
For Each rng In rngOffenders.Cells
Worksheets("Template").Range("LastName").Value = rng.Value
Calculate
Worksheets("Template").PrintOut
Next rng
End Sub
Regarding the duplicate printing, my guess, without testing, is that by Show the print dialog, you're invoking print against the first/active sheet once you press "OK". Then, as you iterate over rngOffenders.Cells, you're printing that sheet again. So, you could start at the second cell in rngOffenders to avoid that.
Dim i As Long
For i = 2 To rngOffenders.Cells.Count
Worksheets("Template").Range("LastName").Value = rngOffenders.Cells(i).Value
Calculate
Worksheets("Template").PrintOut
Next rng
For the printer settings, that is more complicated. See here:
The best way of doing this is by using API calls. The following article gives you a VB code sample which does this:
Q230743
Only one “problem” with this code: It is written for VB and uses Printer.DeviceName to return the name of the currently selected printer. In Word VBA, you need to substitute this with ActivePrinter. The problem is that the strings returned by these commands are slightly different, even though they both get the name of the printer from the name assigned in Control Panel | Printers. For instance.:
ActivePrinter: HP LaserJet 6L PCL on LPT1:
Printer.DeviceName: HP LaserJet 6L PCL
So you'll need to test and modify the code sample accordingly.
If you don't want to use API calls, however, you can install a duplicate printer driver with the duplex property set and print to that (by changing the ActivePrinter).
The linked KB article demonstrates (at length) how to set the printer to duplex printing. Most of the same code should be used for the inverse operation, you'd just need to figure out what value to pass for that property.
Test Procedure:
Place this in a standard module. Note the possible need to adjust the length of printer string (removing the port component e.g., "HP Ink Jet Fantastico on LP02", etc.)
Option Explicit
Sub test()
Dim pName As String
pName = ActivePrinter
' Note you may need to adjust this value to remove the port string component
pName = Left(pName, (Len(pName) - 9))
SetPrinterDuplex pName, 1 '1 = NOT duplex printing.
'Here you might want to actually print something, for example:
Worksheets("Template").PrintOut
End Sub
In a separate module, place all of the printer-related code. NB: I am on a machine with no printer access, so I am unable to test or further debug this solution.
Option Explicit
Public Type PRINTER_DEFAULTS
pDatatype As Long
pDevmode As Long
DesiredAccess As Long
End Type
Public Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
Public Const DM_DUPLEX = &H1000&
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)
Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
Public Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long
Public Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal Command As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)
' ==================================================================
' SetPrinterDuplex
'
' Programmatically set the Duplex flag for the specified printer
' driver's default properties.
'
' Returns: True on success, False on error. (An error will also
' display a message box. This is done for informational value
' only. You should modify the code to support better error
' handling in your production application.)
'
' Parameters:
' sPrinterName - The name of the printer to be used.
'
' nDuplexSetting - One of the following standard settings:
' 1 = None
' 2 = Duplex on long edge (book)
' 3 = Duplex on short edge (legal)
'
' ==================================================================
Public Function SetPrinterDuplex(ByVal sPrinterName As String, _
ByVal nDuplexSetting As Long) As Boolean
Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim pinfo As PRINTER_INFO_2
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim yPInfoMemory() As Byte
Dim nBytesNeeded As Long
Dim nRet As Long, nJunk As Long
On Error GoTo cleanup
'#### I removed this block because it was preventing you from changing the duplex settings
' If (nDuplexSetting < 1) Or (nDuplexSetting > 3) Then
' MsgBox "Error: dwDuplexSetting is incorrect."
' Exit Function
' End If
'####
pd.DesiredAccess = PRINTER_ALL_ACCESS
nRet = OpenPrinter(sPrinterName, hPrinter, pd)
If (nRet = 0) Or (hPrinter = 0) Then
If Err.LastDllError = 5 Then
MsgBox "Access denied -- See the article for more info."
Else
MsgBox "Cannot open the printer specified " & _
"(make sure the printer name is correct)."
End If
Exit Function
End If
nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then
MsgBox "Cannot get the size of the DEVMODE structure."
GoTo cleanup
End If
ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Cannot get the DEVMODE structure."
GoTo cleanup
End If
Call CopyMemory(dm, yDevModeData(0), Len(dm))
If Not CBool(dm.dmFields And DM_DUPLEX) Then
MsgBox "You cannot modify the duplex flag for this printer " & _
"because it does not support duplex or the driver " & _
"does not support setting it from the Windows API."
GoTo cleanup
End If
dm.dmDuplex = nDuplexSetting
Call CopyMemory(yDevModeData(0), dm, Len(dm))
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), _
DM_IN_BUFFER Or DM_OUT_BUFFER)
If (nRet < 0) Then
MsgBox "Unable to set duplex setting to this printer."
GoTo cleanup
End If
Call GetPrinter(hPrinter, 2, 0, 0, nBytesNeeded)
If (nBytesNeeded = 0) Then GoTo cleanup
ReDim yPInfoMemory(nBytesNeeded + 100) As Byte
nRet = GetPrinter(hPrinter, 2, yPInfoMemory(0), nBytesNeeded, nJunk)
If (nRet = 0) Then
MsgBox "Unable to get shared printer settings."
GoTo cleanup
End If
Call CopyMemory(pinfo, yPInfoMemory(0), Len(pinfo))
pinfo.pDevmode = VarPtr(yDevModeData(0))
pinfo.pSecurityDescriptor = 0
Call CopyMemory(yPInfoMemory(0), pinfo, Len(pinfo))
nRet = SetPrinter(hPrinter, 2, yPInfoMemory(0), 0)
If (nRet = 0) Then
MsgBox "Unable to set shared printer settings."
End If
SetPrinterDuplex = CBool(nRet)
cleanup:
If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)
End Function
You can print the first page twice like this:
Dim i As Long, k As Long
Dim lpc As Long
lpc = ActiveSheet.HPageBreaks.Count
For i = 1 To lpc + 1
If i = 1 Then
k = 2
Else
k = 1
End If
ActiveSheet.PrintOut from:=i, To:=i, Copies:=k
Next

How to convert Image from a Picturebox(Image in VB6) to String(Base64)?

Good Morning.
I have a program in vb6 that has a control named Image3, now to have this control an image, I have to browse a picture for it preferably .jpg file because i will save it in my SQL now I dont need to do that because in the near future the system will go slow because a lot of image will be surely saved. The best way to do (for me) is to convert it to string and vice versa. Honestly I dont want to ask this question because it is searchable and the codes I see that will fit to it is IO.MemoryStream my problem is I cant see it in the references. Now I try to download a new one but the VB6 doesnt accept it.
Can someone light me up with this one? Other way to convert image to string.
The reason why im doing this is i will use the image that converted to string in my select command because the memorystream are the uniqueness of the image.
In general I dont want to upload the same image ever again.
TYSM
Already done with the this question and to those want the same as I did here is the full code.
Private Sub Image3_DblClick()
CommonDialog1.InitDir = App.Path
CommonDialog1.FileName = ""
CommonDialog1.Filter = "Image files|*.jpg;"
CommonDialog1.DialogTitle = "All Picture Files"
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
Dim arrImageByte() As Byte
Dim bytBuf() As Byte
Dim fNum As Integer
Dim rs As New ADODB.Recordset
Dim strPhotoPath As String
Dim FileInputData As String
Dim s As String
Image3.Picture = LoadPicture(CommonDialog1.FileName)
strPhotoPath = CommonDialog1.FileName
ReDim arrImageByte(FileLen(strPhotoPath))
fNum = FreeFile()
Open strPhotoPath For Binary As #fNum
Get #fNum, , arrImageByte
Close fNum
Open CommonDialog1.FileName For Binary As #1
FileInputData = String(LOF(1), 0)
Get #1, 1, FileInputData
Close #1
bytBuf = FileInputData
s = CryptoBase64.Encode(bytBuf)
Text8.Text = s
Close
End If
--------------------------Class Module------------------------------
Option Explicit
Private Const CLASS_EXCEPT_BASE As Long = &H8004E300
Public Enum CryptoBase64ExceptEnum
cbxGetOSVersFailed = CLASS_EXCEPT_BASE
cbxNotNT
cbxWinXPOrLaterReqd
cbxWinVistaOrLaterReqd
cbxStringToBinaryFailed
cbxBinaryToStringFailed
End Enum
Public Enum Base64FormatEnum
bfmtCrLF = 0
bfmtLfOnly
bfmtNone
End Enum
Public Enum OSVersionEnum
osvWinXP = 501
osvWinVista = 600
End Enum
Private Const VER_PLATFORM_WIN32_NT As Long = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
' Operating System Value
' Windows 3.1 3
' Windows 95 4
' Windows 98 4
' Windows Me 4
' Windows NT 3.51 3
' Windows NT 4.0 4
' Windows 2000 5
' Windows XP 5
' Windows .Net Server 5
' Windows 2003 Server 5
' Windows 2003 R2 Server 5
' Windows Vista 6
' Windows 2008 Server 6
dwMinorVersion As Long
' Operating System Value
' Windows 3.1 1
' Windows 95 0
' Windows 98 10
' Windows Me 90
' Windows NT 3.51 51
' Windows NT 4.0 0
' Windows 2000 0
' Windows XP 1
' Windows .Net Server 1
' Windows 2003 Server 2
' Windows 2003 R2 Server 2
' Windows Vista 0
' Windows 2008 Server 0
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
'Extended information (optional), i.e. OSVERSIONINFOEX:
wServicePackMajor As Integer
wServicePackMinor As Integer
wSuiteMask As Integer
wProductType As Byte
' Operating System Value
' NT Workstation 1
' NT Domain Controller 2
' NT Server 3
wReserved As Byte
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Const CRYPT_STRING_BASE64 As Long = 1
Private Const CRYPT_STRING_NOCR As Long = &H80000000
Private Const CRYPT_STRING_NOCRLF As Long = &H40000000
Private Declare Function CryptBinaryToString Lib "Crypt32" Alias "CryptBinaryToStringW" _
(ByRef pbBinary As Byte, _
ByVal cbBinary As Long, _
ByVal dwFlags As Long, _
ByVal pszString As Long, _
ByRef pcchString As Long) As Long
Private Declare Function CryptStringToBinary Lib "Crypt32" Alias "CryptStringToBinaryW" _
(ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByRef pdwSkip As Long, _
ByRef pdwFlags As Long) As Long
Private m_OSVersion As OSVersionEnum
Private m_lngBase64Format As Long
Public Property Get Base64Format() As Base64FormatEnum
If m_lngBase64Format = 0 Then
Base64Format = bfmtCrLF
ElseIf m_lngBase64Format = CRYPT_STRING_NOCR Then
Base64Format = bfmtLfOnly
Else
Base64Format = bfmtNone
End If
End Property
Public Property Let Base64Format(ByVal Format As Base64FormatEnum)
If Format = bfmtLfOnly Then
If m_OSVersion < osvWinXP Then
Err.Raise cbxWinXPOrLaterReqd, "CryptoBase64.Base64Format", "This format is only supported in Windows XP/2003 and later"
Else
m_lngBase64Format = CRYPT_STRING_NOCR
End If
ElseIf Format = bfmtNone Then
If m_OSVersion < osvWinVista Then
Err.Raise cbxWinVistaOrLaterReqd, "CryptoBase64.Base64Format", "This format is only supported in Windows Vista/2008 and later"
Else
m_lngBase64Format = CRYPT_STRING_NOCRLF
End If
Else
m_lngBase64Format = 0
End If
End Property
Public Function Decode(ByRef Base64Buf As String) As Byte()
Dim lngOutLen As Long
Dim dwActualUsed As Long
Dim bytBuf() As Byte
' Determine output buffer length required. Note:
' StrPtr(vbNullString) is just a way to get a null pointer,
' even though we're really talking about a Byte array here.
CryptStringToBinary StrPtr(Base64Buf), _
Len(Base64Buf), _
CRYPT_STRING_BASE64, _
StrPtr(vbNullString), _
lngOutLen, _
0&, _
dwActualUsed
' Convert Base64 to binary.
ReDim bytBuf(lngOutLen - 1)
If CryptStringToBinary(StrPtr(Base64Buf), _
Len(Base64Buf), _
CRYPT_STRING_BASE64, _
VarPtr(bytBuf(0)), _
lngOutLen, _
0&, _
dwActualUsed) = 0 Then
Err.Raise cbxStringToBinaryFailed, "CryptoBase64.Decode", "CryptStringToBinary failed, error " & CStr(Err.LastDllError)
Else
Decode = bytBuf
End If
'Open App.Path & "\MyTestGif.gif" For Binary As #1
'Put #1, 1, Decode
'Close #1
End Function
Public Function Encode(ByRef BinaryBuf() As Byte) As String
Dim bytBuf() As Byte
Dim lngOutLen As Long
Dim strBase64 As String
'Determine Base64 output String length required.
CryptBinaryToString BinaryBuf(0), _
UBound(BinaryBuf) + 1, _
CRYPT_STRING_BASE64 Or m_lngBase64Format, _
StrPtr(vbNullString), _
lngOutLen
'Convert binary to Base64.
Encode = String(lngOutLen, 0)
If CryptBinaryToString(BinaryBuf(0), _
UBound(BinaryBuf) + 1, _
CRYPT_STRING_BASE64 Or m_lngBase64Format, _
StrPtr(Encode), _
lngOutLen) = 0 Then
Err.Raise cbxBinaryToStringFailed, "CryptoBase64.Encode", "CryptBinaryToString failed, error " & CStr(Err.LastDllError)
End If
End Function
Public Property Get OSVersion() As OSVersionEnum
OSVersion = m_OSVersion
End Property
Private Sub Class_Initialize()
Dim osvinfData As OSVERSIONINFO
With osvinfData
.dwOSVersionInfoSize = Len(osvinfData)
.szCSDVersion = ""
If GetVersionEx(osvinfData) = 0 Then
Err.Raise cbxGetOSVersFailed, "CryptoBase64 Initialize", "GetVersionEx failed, error " & CStr(Err.LastDllError)
End If
If .dwPlatformId <> VER_PLATFORM_WIN32_NT Then
Err.Raise cbxNotNT, "CryptoBase64 Initialize", "CryptoAPI is only available on NT-based OSs"
End If
m_OSVersion = .dwMajorVersion * 100 + .dwMinorVersion
End With
Base64Format = bfmtCrLF
End Sub
Just add picbox,button and and a module for this to work

Word 2010 VBA to select printer without changing system default printer

In Word 2010, I'm trying to create a macro that sets the current printer to a specific color printer on our network, without making that printer the user's system default printer. I've hacked together some code below from samples I've found on the web. Everything works, except that the SetColorPrinterEast Sub changes the user's system default printer, which I do not want. I suspect the DoNotSetAsSysDefault in that sub is not working as intended, but I don't know what to do about it. See the comments in the code for further explanation. Any thoughts will be greatly appreciated. Thanks in advance!!!
'I found the code block below on the web. I don't understand it, but
'it seems to work properly with the "SetDefaultPrinter"
'Sub below to get the system default printer.
Public Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" _
(ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
' This code successfully sets the document to print from
' the system default printer.
Public Sub SetDefaultPrinter()
Dim strReturn As String
Dim intReturn As Integer
strReturn = Space(255)
intReturn = GetProfileString("Windows", ByVal "device", "", _
strReturn, Len(strReturn))
If intReturn Then
strReturn = UCase(Left(strReturn, InStr(strReturn, ",") - 1))
End If
With Dialogs(wdDialogFilePrintSetup)
.Printer = strReturn
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
' This code correctly sets the printer to a specific color printer
' on our network. The problem is that it makes that printer
' the user's system default printer. I would think that the
' .DoNotSetAsSysDefault = True line would solve this problem
' but still this sub changes the user's system default printer.
Public Sub SetColorPrinterEast()
With Dialogs(wdDialogFilePrintSetup)
.Printer = "\\[*NETWORK PATH*]\Color Printer East"
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
I had this same problem a few years back, got around it by storing the current default print in a variable, changing the default printer to the one I need, printing, then changing the default printer back to users original default.
This was designed and written for Word 2003 but has continued to work in Word 2010.
Here is the specific code I used:
'Define Printer to add and printer to delete
Const PrintPath = "\\prn001l0003\Colour04"
Const PrintDeletePath = "\\prn001l0003\Colour02"
' Used to see what printers are set up on the user, and to set a new network printer
Public Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, _
ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" (ByVal Ptr As Long) As Long
Const PRINTER_ENUM_CONNECTIONS = &H4
Const PRINTER_ENUM_LOCAL = &H2
Public Sub PrintLetter(ByRef LetterBrochures() As String)
'Print the document
Dim STDprinter As String
On Error Resume Next
Call CheckPrinterLoaded ' Get users loaded printers, remove any old printers used here,
' and add printer I want to users printers
STDprinter = Application.ActivePrinter ' store the current default printer
Application.ActivePrinter = PrintPath ' change default printer to want I want
On Error GoTo printLetterError
Application.DisplayAlerts = wdAlertsNone ' prevent Word showing any alert/warnings etc
With ActiveDocument ' first page is letterhead from tray 2, all others from tray 1, print
.PageSetup.FirstPageTray = 3 ' 3 = Tray 2 on MFLaser
.PageSetup.OtherPagesTray = 1 ' 1 = Tray 1 on MFLaser
.PrintOut Background:=False
End With
Application.DisplayAlerts = wdAlertsAll ' enable Word alets/warning etc
Application.ActivePrinter = STDprinter 'change back users default printer
Exit Sub
printLetterError:
MsgBox "Error printing letter" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"
ActiveDocument.Close False
End
End Sub
Public Function CheckPrinterLoaded()
'get users printers
'look for and delete defined printer, PrintDeletePath
'add printer I want to users printers, PrintPath
Dim StrPrinters As Variant, x As Long
Dim StrSetPrinter As String
Dim objNetwork
Set objNetwork = CreateObject("WScript.Network")
StrPrinters = ListPrinters
'Fist check whether the array is filled with anything, by calling another function, IsBounded.
If IsBounded(StrPrinters) Then
For x = LBound(StrPrinters) To UBound(StrPrinters)
If StrPrinters(x) = PrintDeletePath Then
objNetwork.RemovePrinterConnection PrintDeletePath
End If
Next x
objNetwork.AddWindowsPrinterConnection PrintPath
Else
MsgBox "No printers found"
End If
End Function
Private Function ListPrinters() As Variant
Dim bSuccess As Boolean
Dim iBufferRequired As Long
Dim iBufferSize As Long
Dim iBuffer() As Long
Dim iEntries As Long
Dim iIndex As Long
Dim strPrinterName As String
Dim iDummy As Long
Dim iDriverBuffer() As Long
Dim StrPrinters() As String
iBufferSize = 3072
ReDim iBuffer((iBufferSize \ 4) - 1) As Long
'EnumPrinters will return a value False if the buffer is not big enough
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
If Not bSuccess Then
If iBufferRequired > iBufferSize Then
iBufferSize = iBufferRequired
Debug.Print "iBuffer too small. Trying again with "; iBufferSize & " bytes."
ReDim iBuffer(iBufferSize \ 4) As Long
End If
'Try again with new buffer
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
End If
If Not bSuccess Then
'Enumprinters returned False
MsgBox "Error enumerating printers."
Exit Function
Else
'Enumprinters returned True, use found printers to fill the array
ReDim StrPrinters(iEntries - 1)
For iIndex = 0 To iEntries - 1
'Get the printername
strPrinterName = Space$(StrLen(iBuffer(iIndex * 4 + 2)))
iDummy = PtrToStr(strPrinterName, iBuffer(iIndex * 4 + 2))
StrPrinters(iIndex) = strPrinterName
Next iIndex
End If
ListPrinters = StrPrinters
End Function
Private Function IsBounded(vArray As Variant) As Boolean
'If the variant passed to this function is an array, the function will return True; otherwise it will return False
On Error Resume Next
IsBounded = IsNumeric(UBound(vArray))
End Function