Related
I am trying to print out section, that is marked as Printarea. This code however sometimes runs good and sometimes it doesn't. There is really no rule with it. The question is, how can I make it 100% runnable.
What it does when it runs good. It prints the area, saves it as Picture and then quits.
What it does when it doesn't. It prints blank white page without any data on it, as if printing blank page. The fact that the page prints, evethough its blank suggests that the saving is not a problem.
Can you help?
OK, I will reveal my cards. This started as "learning this area of VBA" project (printing saving pictures), so I tried to pull data from website about my arrival to work and then printing what day it is, how far are we with the week so far etc. The whole code is revealed since the fixed range helped a bit, but I still get blank pages in 10% of cases when ran manually and 50% of cases when ran after win start via vbs script. basically I noticed that stressed CPU is in direct correlation to succesful code run. All files are local except for the website pull which is always succesful.
VBS:
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
objExcel.DisplayAlerts = False
objExcel.Application.Quit
Set objExcel = Nothing
Module 1
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
Application.DisplayAlerts = False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "*Some-secret-corporate-website*"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("*someAJAXcorporateElement*")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
Dim intLastRow As Integer
Dim intLastCol As Integer
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
With ThisWorkbook.Sheets(1)
.PageSetup.PrintArea = .Range("A1", .Cells(37, 17)).Address
End With
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="*MyCorporatePath*", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "*MyCorporatePath*"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Requirement: To save the PrintArea of the first worksheet as a bmp file.
Original procedure:
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="C:\Users\insertyourname\Pictures\savedImage.bmp", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
The procedure as originally stated in the post creates a range named area using the PageSetup.PrintArea property as the reference for the range.
If the PrintAreais set to the entire sheet then the PrintArea property would be equal to an empty string and the instruction below will generate an error.
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
As the procedure is printing a blank page, we can assume that the PrintArea property is a valid A1-style reference.
The printing of a blank page when the PageSetup.PrintArea property is a valid A1-style reference could be replicated at least in the following cases:
1. When the range corresponding to the PrintArea is in fact a range of empty cells,
2. When the range corresponding to the PrintArea has its rows or columns hidden,
3. When printing a chart and although the rows and columns of the chart are visible the rows or columns of the Chart.SourceData are hidden, thus the chart is blank.
The original procedure has been adjusted in order to ask the user to validate the output and if the output is blank them it presents the user with the printed range (i.e. the Print.Area) so the necessary corrections can be applied.
Sub Save_PrintArea_As_bmp()
Dim ws As Worksheet
Dim oCht As Object
Dim ddZoomCoef As Double
Dim rArea As Range
Set ws = ThisWorkbook.Worksheets(1) 'Modify as required
With ws
ddZoomCoef = 100 / .Parent.Windows(1).Zoom
Set rArea = .Range(.PageSetup.PrintArea)
rArea.CopyPicture xlPrinter
Set oCht = .ChartObjects.Add(0, 0, _
rArea.Width * ddZoomCoef, rArea.Height * ddZoomCoef)
End With
Application.DisplayAlerts = False
With oCht
.Chart.Paste
If MsgBox("Is the printed page blank?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Save PrintArea As bmp") = vbYes Then
.Delete
MsgBox "This is the PrintArea, validate that the range is visible."
With ws
.Activate
Application.Goto .Cells(1), 1
Application.Goto rArea
Exit Sub
Application.DisplayAlerts = True
End With
Else
.Chart.Export Filename:="D:\#D_Trash\savedImage.bmp", _
Filtername:="bmp" 'Modify as required
.Delete
End If: End With
Application.DisplayAlerts = True
End Sub
It sounds like you want to save an image of the area that would be printed, even if the user has not specified a print area. The problem is that Excel has no .PrintArea value if one has not been specified by a user. See below for further details.
To ensure the code works as intended, you can either stop the code early if no print area has been set:
If ThisWorkbook.Sheets(1).PageSetup.PrintArea = vbNullString Then
MsgBox "No print area has been set.", vbCritical, "Save Sheet"
Exit Sub
End If
Or you can set the print area manually to include all values by placing this at the start of the macro:
Dim intLastRow as Integer
Dim intLastCol As Integer
With ThisWorkbook.Sheets(1)
If .PageSetup.PrintArea = vbNullString Then
intLastRow = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
intLastCol = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.PageSetup.PrintArea = .Range("A1", .Cells(intLastRow, intLastCol)).Address
End If
End With
Note that this closely mimics the default print area to start from A1, but does not include more distant cells that include only formatting or objects. This is likely sufficient for your needs, but it could be adjusted further if you didn't want it to start from A1 or if you need to include cells that contain only formatting or objects.
Notes on "Default Print Area"
There isn't strictly a default print area determined by Excel at the time of printing. It instead prints as many continuous pages as necessary to include all cells that contain any values, formatting or objects, starting from A1 (regardless of where content starts). This is not necessarily a rectangular area and the number of pages printed can depend on the print order. It also does not necessarily include all cells in the .UsedArea
For example, enter a value in W15 (3 pages to the right) and E70 (1 page down). If printing without setting a print area, Excel will start with a blank page from A1. The default print order setting of down-then-across will result in 5 pages being printed from the layout below: Pages 1,4,2,5,3. Changing to print across-then-down will result in only 4 pages being printed: Pages 1,2,3,4. Manually setting the print area instead results in all 6 pages being printed in whichever order is specified.
Upon learning, that Chart.Paste is causing the problem and upon researching in web I found that Chart.Paste is broken terribly in VBA itself. One has to manually activate it through the code. I also found that the printarea is no longer needed since I just passed the desired range to PrintArea and then wrote the PrintArea value to another unknown. So here is the code, that fixes the buggy Chart.Paste
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area As Range
Dim intLastRow As Integer
Dim intLastCol As Integer
Dim chartName As String
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = Range("A1", Cells(37, 17))
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
chartName = oCht.Chart.Name
ThisWorkbook.Sheets(1).Activate 'this one **********
oCht.Activate 'this one too ***********
Application.Wait (Now + TimeValue("0:00:02"))
oCht.Chart.Paste
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
oCht.Chart.Export Filename:="somePath", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
this question was already discussed in different topics but the solutions are not helping me. I am trying to calculate and display a series of data for a chart. Something like "Calculate y" --> "Update Series" --> wait 100 ms --> "Recalculate". The program is running but the chart is only updated when the Main-Sub is completely finished (and not after each 100 ms).
The series is based entirely on arrays within VBA and do not refer to Cells.
When I'm running the program with break points directly after the "sleep" function, the chart is updated.
For me the DoEvents and chart.Refresh method are not giving me the results I want. Does somebody has an idea? Thanks for your help guys.
Sub Main()
Dim ws As Worksheet
Dim mychart As Chart
Dim ser As Series
Dim x(1 To 10) As Double
Dim y(1 To 10) As Double
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Set mychart = ws.ChartObjects("Chart 1").Chart
Call DeletePlot(mychart)
For i = 1 To 10
x(i) = i
y(i) = i
Next i
' Plot first data
Set ser = mychart.SeriesCollection.NewSeries
With ser
.Values = y
.XValues = x
End With
Dim j As Integer
For j = 2 To 4
For i = 1 To 10
y(i) = i ^ j ' update data
Next i
With ser
.Values = y ' update series
End With
mychart.Refresh ' Does not work
DoEvents ' Does not work
Sleep (100)
Next j
End Sub
The sleep function:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
The PlotDelete Function:
Sub DeletePlot(mychart As Chart)
Dim ser As Series
For Each ser In mychart.SeriesCollection
ser.Delete
Next ser
End Sub
A timer such as Application.OnTime or a windows API timer see link gave me the desired behaviour.
I'd like to be able to copy a cell and paste ONLY number formats. Unfortunately, there is no built-in option in the PasteSpecial command.
Is there a way to press the copy button, select some destination cells, run a macro, and be able to retrieve the copied cells in a way analogous to the Selection object in VBA so that I can use its properties?
The only alternative I can think of is pasting to a known empty range (very far away) and then using that intermediate range, as below:
Dim A As Range
Set A = Range("ZZ99999")
A.PasteSpecial Paste:=xlPasteAll
Selection.NumberFormat = A.NumberFormat
Thanks!
Find olelib.tlb on the Internet (Edanmo's OLE interfaces & functions). There should be plenty of download links. Download and reference from your VBA project (Tools - References).
Note that it does not contain any executable code, only declarations of OLE functions and interfaces.
Also you might notice it's quite big, about 550kb. You can extract only the needed interfaces from it and recompile to get a much lighter TLB file, but that is up to you.
(If you are really unhappy with a TLB, there is also the dark magic route where you don't need any TLBs at all because you create assembly stubs on the fly to call vTable methods directly, but I won't be feeling like porting the below code this way.)
Then create a helper module and put this code into it:
Option Explicit
' No point in #If VBA7 and PtrSafe, as the Edanmo's olelib is 32-bit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Public Function GetCopiedRange() As Excel.Range
Dim CF_LINKSOURCE As Long
CF_LINKSOURCE = olelib.RegisterClipboardFormat("Link Source")
If CF_LINKSOURCE = 0 Then Err.Raise 5, , "Failed to obtain clipboard format CF_LINKSOURCE"
If OpenClipboard(0) = 0 Then Err.Raise 5, , "Failed to open clipboard."
On Error GoTo cleanup
Dim hGlobal As Long
hGlobal = GetClipboardData(CF_LINKSOURCE)
If hGlobal = 0 Then Err.Raise 5, , "Failed to get data from clipboard."
Dim pStream As olelib.IStream
Set pStream = olelib.CreateStreamOnHGlobal(hGlobal, 0)
Dim IID_Moniker As olelib.UUID
olelib.CLSIDFromString "{0000000f-0000-0000-C000-000000000046}", IID_Moniker
Dim pMoniker As olelib.IMoniker
olelib.OleLoadFromStream pStream, IID_Moniker, pMoniker
Set GetCopiedRange = RangeFromCompositeMoniker(pMoniker)
cleanup:
Set pMoniker = Nothing 'To make sure moniker releases before the stream
CloseClipboard
If Err.Number > 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
Private Function RangeFromCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As Excel.Range
Dim monikers() As olelib.IMoniker
monikers = SplitCompositeMoniker(pCompositeMoniker)
If UBound(monikers) - LBound(monikers) + 1 <> 2 Then Err.Raise 5, , "Invalid composite moniker."
Dim binding_context As olelib.IBindCtx
Set binding_context = olelib.CreateBindCtx(0)
Dim WorkbookUUID As olelib.UUID
olelib.CLSIDFromString "{000208DA-0000-0000-C000-000000000046}", WorkbookUUID
Dim wb As Excel.Workbook
monikers(LBound(monikers)).BindToObject binding_context, Nothing, WorkbookUUID, wb
Dim pDisplayName As Long
pDisplayName = monikers(LBound(monikers) + 1).GetDisplayName(binding_context, Nothing)
Dim raw_range_name As String ' Contains address in the form of "!SheetName!R1C1Local", need to convert to non-local
raw_range_name = olelib.SysAllocString(pDisplayName)
olelib.CoGetMalloc(1).Free pDisplayName
Dim split_range_name() As String
split_range_name = Split(raw_range_name, "!")
Dim worksheet_name As String, range_address As String
worksheet_name = split_range_name(LBound(split_range_name) + 1)
range_address = Application.ConvertFormula(ConvertR1C1LocalAddressToR1C1(split_range_name(LBound(split_range_name) + 2)), xlR1C1, xlA1)
Set RangeFromCompositeMoniker = wb.Worksheets(worksheet_name).Range(range_address)
End Function
Private Function SplitCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As olelib.IMoniker()
Dim MonikerList As New Collection
Dim enumMoniker As olelib.IEnumMoniker
Set enumMoniker = pCompositeMoniker.Enum(True)
If enumMoniker Is Nothing Then Err.Raise 5, , "IMoniker is not composite"
Dim currentMoniker As olelib.IMoniker
Do While enumMoniker.Next(1, currentMoniker) = olelib.S_OK
MonikerList.Add currentMoniker
Loop
If MonikerList.Count > 0 Then
Dim res() As olelib.IMoniker
ReDim res(1 To MonikerList.Count)
Dim i As Long
For i = 1 To MonikerList.Count
Set res(i) = MonikerList(i)
Next
SplitCompositeMoniker = res
Else
Err.Raise 5, , "No monikers found in the composite moniker."
End If
End Function
Private Function ConvertR1C1LocalAddressToR1C1(ByVal R1C1LocalAddress As String) As String
' Being extra careful here and not doing simple Replace(Replace()),
' because e.g. non-localized row letter may be equal to localized column letter which will lead to double replace.
Dim row_letter_local As String, column_letter_local As String
row_letter_local = Application.International(xlUpperCaseRowLetter)
column_letter_local = Application.International(xlUpperCaseColumnLetter)
Dim row_letter_pos As Long, column_letter_pos As Long
row_letter_pos = InStr(1, R1C1LocalAddress, row_letter_local, vbTextCompare)
column_letter_pos = InStr(1, R1C1LocalAddress, column_letter_local, vbTextCompare)
If row_letter_pos = 0 Or column_letter_pos = 0 Or row_letter_pos >= column_letter_pos Then Err.Raise 5, , "Invalid R1C1Local address"
If Len(row_letter_local) = 1 And Len(column_letter_local) = 1 Then
Mid$(R1C1LocalAddress, row_letter_pos, 1) = "R"
Mid$(R1C1LocalAddress, column_letter_pos, 1) = "C"
ConvertR1C1LocalAddressToR1C1 = R1C1LocalAddress
Else
ConvertR1C1LocalAddressToR1C1 = "R" & Mid$(R1C1LocalAddress, row_letter_pos + Len(row_letter_local), column_letter_pos - (row_letter_pos + Len(row_letter_local))) & "C" & Mid$(R1C1LocalAddress, column_letter_pos + Len(column_letter_local))
End If
End Function
Credits go to Alexey Merson.
Here's one way. Obviously you'll have to change the range to suit your situation, but it should get you the general idea:
Dim foo As Variant
foo = Sheet1.Range("A1:A10").NumberFormat
Sheet1.Range("D1:D10").NumberFormat = foo
Which really can be simplified to:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1:A10").NumberFormat
and if all of your formats in the range are the same, you can just do:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1").NumberFormat
Enough rambling...you get the idea.
This question already has answers here:
How to find the number of dimensions that an array has?
(3 answers)
Closed 2 years ago.
Does anyone know how to return the number of dimensions of a (Variant) variable passed to it in VBA?
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
That's the only way I could come up with. Not pretty….
Looking at MSDN, they basically did the same.
To return the number of dimensions without swallowing errors:
#If VBA7 Then
Private Type Pointer: Value As LongPtr: End Type
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
Private Type Pointer: Value As Long: End Type
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If
Private Type TtagVARIANT
vt As Integer
r1 As Integer
r2 As Integer
r3 As Integer
sa As Pointer
End Type
Public Function GetDims(source As Variant) As Integer
Dim va As TtagVARIANT
RtlMoveMemory va, source, LenB(va) ' read tagVARIANT '
If va.vt And &H2000 Then Else Exit Function ' exit if not an array '
If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa) ' read by reference '
If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2 ' read cDims from tagSAFEARRAY '
End Function
Usage:
Sub Examples()
Dim list1
Debug.Print GetDims(list1) ' >> 0 '
list1 = Array(1, 2, 3, 4)
Debug.Print GetDims(list1) ' >> 1 '
Dim list2()
Debug.Print GetDims(list2) ' >> 0 '
ReDim list2(2)
Debug.Print GetDims(list2) ' >> 1 '
ReDim list2(2, 2)
Debug.Print GetDims(list2) ' >> 2 '
Dim list3(0 To 0, 0 To 0, 0 To 0)
Debug.Print GetDims(list3) ' >> 3 '
End Sub
#cularis and #Issun have perfectly adequate answers for the exact question asked. I'm going to question your question, though. Do you really have a bunch of arrays of unknown dimension count floating around? If you're working in Excel, the only situation where this should occur is a UDF where you might get passed either a 1-D array or a 2-D array (or a non-array), but nothing else.
You should almost never have a routine that expects something arbitrary though. And thus you probably shouldn't have a general "find # of array dimensions" routine either.
So, with that in mind, here is the routines I use:
Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9
'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
Debug.Assert IsArray(arr)
Debug.Assert dimNum > 0
'Note that it is possible for a VBA array to have no dimensions (i.e.
''LBound' raises an error even on the first dimension). This happens
'with "unallocated" (borrowing Chip Pearson's terminology; see
'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
'essentially arrays that have been declared with 'Dim arr()' but never
'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.
On Error Resume Next
Dim lb As Long
lb = LBound(arr, dimNum)
'No error (0) - array has given dimension
'Subscript out of range (9) - array doesn't have given dimension
arrHasDim = (Err.Number = ERR_VBA_NONE)
Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
On Error GoTo 0
End Function
'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 1) Then
isVect = Not arrHasDim(arg, 2)
End If
End Function
'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 2) Then
isMat = Not arrHasDim(arg, 3)
End If
End Function
Note the link to Chip Pearson's excellent web site: http://www.cpearson.com/excel/VBAArrays.htm
Also see: How do I determine if an array is initialized in VB6?. I personally don't like the undocumented behavior it relies on, and performance is rarely that important in the Excel VBA code I'm writing, but it's interesting nonetheless.
For arrays, MS has a nice method that involves looping through until an error occurs.
"This routine tests the array named Xarray by testing the LBound of each dimension. Using a For...Next loop, the routine cycles through the number of possible array dimensions, up to 60000, until an error is generated. Then the error handler takes the counter step that the loop failed on, subtracts one (because the previous one was the last one without an error), and displays the result in a message box...."
http://support.microsoft.com/kb/152288
Cleaned-up version of code (decided to write as a function, not sub):
Function NumberOfDimensions(ByVal vArray As Variant) As Long
Dim dimnum As Long
On Error GoTo FinalDimension
For dimnum = 1 To 60000
ErrorCheck = LBound(vArray, dimnum)
Next
FinalDimension:
NumberOfDimensions = dimnum - 1
End Function
Microsoft has documented the structure of VARIANT and SAFEARRAY, and using those you can parse the binary data to get the dimensions.
Create a normal code module. I call mine "mdlDims". You would use it by calling the simple function 'GetDims' and passing it an array.
Option Compare Database
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
lpSAFEARRAY As Long
data(4) As Byte
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
VT_EMPTY = &H0
VT_NULL
VT_I2
VT_I4
VT_R4
VT_R8
VT_CY
VT_DATE
VT_BSTR
VT_DISPATCH
VT_ERROR
VT_BOOL
VT_VARIANT
VT_UNKNOWN
VT_DECIMAL
VT_I1 = &H10
VT_UI1
VT_UI2
VT_I8
VT_UI8
VT_INT
VT_VOID
VT_HRESULT
VT_PTR
VT_SAFEARRAY
VT_CARRAY
VT_USERDEFINED
VT_LPSTR
VT_LPWSTR
VT_RECORD = &H24
VT_INT_PTR
VT_UINT_PTR
VT_ARRAY = &H2000
VT_BYREF = &H4000
End Enum
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim varArray As ARRAY_VARIANT
Dim lpSAFEARRAY As Long
Dim sArr As SAFEARRAY
'Inspect the Variant
CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
'If the Variant is pointing to an array...
If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then
'Get the pointer to the SAFEARRAY from the Variant
CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
'If the pointer is not Null
If Not lpSAFEARRAY = 0 Then
'Read the array dimensions from the SAFEARRAY
CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
'and return them
GetDims = sArr.cDims
Else
'The array is uninitialized
GetDims = 0
End If
Else
'Not an array, you could choose to raise an error here
GetDims = 0
End If
End Function
I presume you mean without using On Error Resume Next which most programmers dislike and which also means that during debugging you can't use 'Break On All Errors' to get the code to stop dead (Tools->Options->General->Error Trapping->Break on All Errors).
For me one solution is to bury any On Error Resume Next into a compiled DLL, in the old days this would have been VB6. Today you could use VB.NET but I choose to use C#.
If Visual Studio is available to you then here is some source. It will return a dictionary, the Dicitionary.Count will return the number of dimensions. The items will also contain the LBound and UBound as a concatenated string. I'm always querying an array not just for its dimensions but also for LBound and UBound of those dimensions so I put these together and return a whole bundle of info in a Scripting Dictionary
Here is C# source, start a Class Library calling it BuryVBAErrorsCS, set ComVisible(true) add a reference to COM library 'Microsoft Scripting Runtime', Register for Interop.
using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;
namespace BuryVBAErrorsCS
{
// Requires adding a reference to COM library Microsoft Scripting Runtime
// In AssemblyInfo.cs set ComVisible(true);
// In Build tab check 'Register for Interop'
public interface IDimensionsAndBounds
{
Scripting.Dictionary DimsAndBounds(Object v);
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IDimensionsAndBounds))]
public class CDimensionsAndBounds : IDimensionsAndBounds
{
public Scripting.Dictionary DimsAndBounds(Object v)
{
Scripting.Dictionary dicDimsAndBounds;
dicDimsAndBounds = new Scripting.Dictionary();
try
{
for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
{
long vLBound = Information.LBound((Array)v, lDimensionLoop);
long vUBound = Information.UBound((Array)v, lDimensionLoop);
string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
dicDimsAndBounds.Add(lDimensionLoop, concat);
}
}
catch (Exception)
{
}
return dicDimsAndBounds;
}
}
}
For Excel client VBA code here is some source
Sub TestCDimensionsAndBounds()
'* requires Tools->References->BuryVBAErrorsCS.tlb
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")
Dim v As Variant
v = rng.Value2
Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
Set o = New BuryVBAErrorsCS.CDimensionsAndBounds
Dim dic As Scripting.Dictionary
Set dic = o.DimsAndBounds(v)
Debug.Assert dic.Items()(0) = "1 4"
Debug.Assert dic.Items()(1) = "1 2"
Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
Set dic = o.DimsAndBounds(s)
Debug.Assert dic.Items()(0) = "1 2"
Debug.Assert dic.Items()(1) = "2 3"
Debug.Assert dic.Items()(2) = "3 4"
Debug.Assert dic.Items()(3) = "4 5"
Debug.Assert dic.Items()(4) = "5 6"
Stop
End Sub
NOTE WELL: This answer handles grid variants pulled off a worksheet with Range.Value as well as arrays created in code using Dim s(1) etc.! Some of the other answers do not do this.
I like to use the fact that with an error, the new variable-value is not charged.
To get the dimension (A_Dim) of an Array (vArray) you can use following code:
On Error Resume Next
A_Dim = -1
Do Until A = "X"
A_Dim = A_Dim + 1
A = "X"
A = UBound(vArray, A_Dim + 1)
Loop
On Error GoTo 0
Function ArrayDimension(ByRef ArrayX As Variant) As Byte
Dim i As Integer, a As String, arDim As Byte
On Error Resume Next
i = 0
Do
a = CStr(ArrayX(0, i))
If Err.Number > 0 Then
arDim = i
On Error GoTo 0
Exit Do
Else
i = i + 1
End If
Loop
If arDim = 0 Then arDim = 1
ArrayDimension = arDim
End Function
I found a pretty simple way to check, probably laden with a bunch of coding faux pas, incorrect lingo, and ill advised techniques but never the less:
Dim i as Long
Dim VarCount as Long
Dim Var as Variant
'generate your variant here
i = 0
VarCount = 0
recheck1:
If IsEmpty(Var(i)) = True Then GoTo VarCalc
i = i + 1
GoTo recheck1
VarCalc:
VarCount= i - 1
Note: VarCount will obviously return a negative number if Var(0) doesn't exist. VarCount is the max reference number for use with Var(i), i is the number of variants you have.
What about just using ubound(var) + 1? That should give you the last element of most of variables (unless it's a custom range, but in that case you should know that info already). The range of a conventional variable (for instance, when using the split function) starts with 0; ubound gives you the last item of the variable. So if you have a variable with 8 elements, for instance, it will go from 0 (lbound) to 7 (ubound), and you can know the quantity of elements just adding ubound(var) + 1. For example:
Public Sub PrintQntElements()
Dim str As String
Dim var As Variant
Dim i As Integer
str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
var = Split(str, "!")
i = UBound(var) + 1
Debug.Print "First element: " & LBound(var)
Debug.Print "Last element: " & UBound(var)
Debug.Print "Quantity of elements: " & i
End Sub
It will print this output to the Inmediate window:
First element: 0
Last element: 7
Quantity of elements: 8
Also, if you are not sure that the first element (lbound) is 0, you can just use:
i = UBound(var) - LBound(var) + 1
This question already has answers here:
How to find the number of dimensions that an array has?
(3 answers)
Closed 2 years ago.
Does anyone know how to return the number of dimensions of a (Variant) variable passed to it in VBA?
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
That's the only way I could come up with. Not pretty….
Looking at MSDN, they basically did the same.
To return the number of dimensions without swallowing errors:
#If VBA7 Then
Private Type Pointer: Value As LongPtr: End Type
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
Private Type Pointer: Value As Long: End Type
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If
Private Type TtagVARIANT
vt As Integer
r1 As Integer
r2 As Integer
r3 As Integer
sa As Pointer
End Type
Public Function GetDims(source As Variant) As Integer
Dim va As TtagVARIANT
RtlMoveMemory va, source, LenB(va) ' read tagVARIANT '
If va.vt And &H2000 Then Else Exit Function ' exit if not an array '
If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa) ' read by reference '
If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2 ' read cDims from tagSAFEARRAY '
End Function
Usage:
Sub Examples()
Dim list1
Debug.Print GetDims(list1) ' >> 0 '
list1 = Array(1, 2, 3, 4)
Debug.Print GetDims(list1) ' >> 1 '
Dim list2()
Debug.Print GetDims(list2) ' >> 0 '
ReDim list2(2)
Debug.Print GetDims(list2) ' >> 1 '
ReDim list2(2, 2)
Debug.Print GetDims(list2) ' >> 2 '
Dim list3(0 To 0, 0 To 0, 0 To 0)
Debug.Print GetDims(list3) ' >> 3 '
End Sub
#cularis and #Issun have perfectly adequate answers for the exact question asked. I'm going to question your question, though. Do you really have a bunch of arrays of unknown dimension count floating around? If you're working in Excel, the only situation where this should occur is a UDF where you might get passed either a 1-D array or a 2-D array (or a non-array), but nothing else.
You should almost never have a routine that expects something arbitrary though. And thus you probably shouldn't have a general "find # of array dimensions" routine either.
So, with that in mind, here is the routines I use:
Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9
'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
Debug.Assert IsArray(arr)
Debug.Assert dimNum > 0
'Note that it is possible for a VBA array to have no dimensions (i.e.
''LBound' raises an error even on the first dimension). This happens
'with "unallocated" (borrowing Chip Pearson's terminology; see
'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
'essentially arrays that have been declared with 'Dim arr()' but never
'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.
On Error Resume Next
Dim lb As Long
lb = LBound(arr, dimNum)
'No error (0) - array has given dimension
'Subscript out of range (9) - array doesn't have given dimension
arrHasDim = (Err.Number = ERR_VBA_NONE)
Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
On Error GoTo 0
End Function
'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 1) Then
isVect = Not arrHasDim(arg, 2)
End If
End Function
'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
If IsObject(arg) Then
Exit Function
End If
If Not IsArray(arg) Then
Exit Function
End If
If arrHasDim(arg, 2) Then
isMat = Not arrHasDim(arg, 3)
End If
End Function
Note the link to Chip Pearson's excellent web site: http://www.cpearson.com/excel/VBAArrays.htm
Also see: How do I determine if an array is initialized in VB6?. I personally don't like the undocumented behavior it relies on, and performance is rarely that important in the Excel VBA code I'm writing, but it's interesting nonetheless.
For arrays, MS has a nice method that involves looping through until an error occurs.
"This routine tests the array named Xarray by testing the LBound of each dimension. Using a For...Next loop, the routine cycles through the number of possible array dimensions, up to 60000, until an error is generated. Then the error handler takes the counter step that the loop failed on, subtracts one (because the previous one was the last one without an error), and displays the result in a message box...."
http://support.microsoft.com/kb/152288
Cleaned-up version of code (decided to write as a function, not sub):
Function NumberOfDimensions(ByVal vArray As Variant) As Long
Dim dimnum As Long
On Error GoTo FinalDimension
For dimnum = 1 To 60000
ErrorCheck = LBound(vArray, dimnum)
Next
FinalDimension:
NumberOfDimensions = dimnum - 1
End Function
Microsoft has documented the structure of VARIANT and SAFEARRAY, and using those you can parse the binary data to get the dimensions.
Create a normal code module. I call mine "mdlDims". You would use it by calling the simple function 'GetDims' and passing it an array.
Option Compare Database
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
End Type
'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
vt As Integer
wReserved1 As Integer
wReserved2 As Integer
wReserved3 As Integer
lpSAFEARRAY As Long
data(4) As Byte
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
VT_EMPTY = &H0
VT_NULL
VT_I2
VT_I4
VT_R4
VT_R8
VT_CY
VT_DATE
VT_BSTR
VT_DISPATCH
VT_ERROR
VT_BOOL
VT_VARIANT
VT_UNKNOWN
VT_DECIMAL
VT_I1 = &H10
VT_UI1
VT_UI2
VT_I8
VT_UI8
VT_INT
VT_VOID
VT_HRESULT
VT_PTR
VT_SAFEARRAY
VT_CARRAY
VT_USERDEFINED
VT_LPSTR
VT_LPWSTR
VT_RECORD = &H24
VT_INT_PTR
VT_UINT_PTR
VT_ARRAY = &H2000
VT_BYREF = &H4000
End Enum
Public Function GetDims(VarSafeArray As Variant) As Integer
Dim varArray As ARRAY_VARIANT
Dim lpSAFEARRAY As Long
Dim sArr As SAFEARRAY
'Inspect the Variant
CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
'If the Variant is pointing to an array...
If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then
'Get the pointer to the SAFEARRAY from the Variant
CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
'If the pointer is not Null
If Not lpSAFEARRAY = 0 Then
'Read the array dimensions from the SAFEARRAY
CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
'and return them
GetDims = sArr.cDims
Else
'The array is uninitialized
GetDims = 0
End If
Else
'Not an array, you could choose to raise an error here
GetDims = 0
End If
End Function
I presume you mean without using On Error Resume Next which most programmers dislike and which also means that during debugging you can't use 'Break On All Errors' to get the code to stop dead (Tools->Options->General->Error Trapping->Break on All Errors).
For me one solution is to bury any On Error Resume Next into a compiled DLL, in the old days this would have been VB6. Today you could use VB.NET but I choose to use C#.
If Visual Studio is available to you then here is some source. It will return a dictionary, the Dicitionary.Count will return the number of dimensions. The items will also contain the LBound and UBound as a concatenated string. I'm always querying an array not just for its dimensions but also for LBound and UBound of those dimensions so I put these together and return a whole bundle of info in a Scripting Dictionary
Here is C# source, start a Class Library calling it BuryVBAErrorsCS, set ComVisible(true) add a reference to COM library 'Microsoft Scripting Runtime', Register for Interop.
using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;
namespace BuryVBAErrorsCS
{
// Requires adding a reference to COM library Microsoft Scripting Runtime
// In AssemblyInfo.cs set ComVisible(true);
// In Build tab check 'Register for Interop'
public interface IDimensionsAndBounds
{
Scripting.Dictionary DimsAndBounds(Object v);
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IDimensionsAndBounds))]
public class CDimensionsAndBounds : IDimensionsAndBounds
{
public Scripting.Dictionary DimsAndBounds(Object v)
{
Scripting.Dictionary dicDimsAndBounds;
dicDimsAndBounds = new Scripting.Dictionary();
try
{
for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
{
long vLBound = Information.LBound((Array)v, lDimensionLoop);
long vUBound = Information.UBound((Array)v, lDimensionLoop);
string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
dicDimsAndBounds.Add(lDimensionLoop, concat);
}
}
catch (Exception)
{
}
return dicDimsAndBounds;
}
}
}
For Excel client VBA code here is some source
Sub TestCDimensionsAndBounds()
'* requires Tools->References->BuryVBAErrorsCS.tlb
Dim rng As Excel.Range
Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")
Dim v As Variant
v = rng.Value2
Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
Set o = New BuryVBAErrorsCS.CDimensionsAndBounds
Dim dic As Scripting.Dictionary
Set dic = o.DimsAndBounds(v)
Debug.Assert dic.Items()(0) = "1 4"
Debug.Assert dic.Items()(1) = "1 2"
Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
Set dic = o.DimsAndBounds(s)
Debug.Assert dic.Items()(0) = "1 2"
Debug.Assert dic.Items()(1) = "2 3"
Debug.Assert dic.Items()(2) = "3 4"
Debug.Assert dic.Items()(3) = "4 5"
Debug.Assert dic.Items()(4) = "5 6"
Stop
End Sub
NOTE WELL: This answer handles grid variants pulled off a worksheet with Range.Value as well as arrays created in code using Dim s(1) etc.! Some of the other answers do not do this.
I like to use the fact that with an error, the new variable-value is not charged.
To get the dimension (A_Dim) of an Array (vArray) you can use following code:
On Error Resume Next
A_Dim = -1
Do Until A = "X"
A_Dim = A_Dim + 1
A = "X"
A = UBound(vArray, A_Dim + 1)
Loop
On Error GoTo 0
Function ArrayDimension(ByRef ArrayX As Variant) As Byte
Dim i As Integer, a As String, arDim As Byte
On Error Resume Next
i = 0
Do
a = CStr(ArrayX(0, i))
If Err.Number > 0 Then
arDim = i
On Error GoTo 0
Exit Do
Else
i = i + 1
End If
Loop
If arDim = 0 Then arDim = 1
ArrayDimension = arDim
End Function
I found a pretty simple way to check, probably laden with a bunch of coding faux pas, incorrect lingo, and ill advised techniques but never the less:
Dim i as Long
Dim VarCount as Long
Dim Var as Variant
'generate your variant here
i = 0
VarCount = 0
recheck1:
If IsEmpty(Var(i)) = True Then GoTo VarCalc
i = i + 1
GoTo recheck1
VarCalc:
VarCount= i - 1
Note: VarCount will obviously return a negative number if Var(0) doesn't exist. VarCount is the max reference number for use with Var(i), i is the number of variants you have.
What about just using ubound(var) + 1? That should give you the last element of most of variables (unless it's a custom range, but in that case you should know that info already). The range of a conventional variable (for instance, when using the split function) starts with 0; ubound gives you the last item of the variable. So if you have a variable with 8 elements, for instance, it will go from 0 (lbound) to 7 (ubound), and you can know the quantity of elements just adding ubound(var) + 1. For example:
Public Sub PrintQntElements()
Dim str As String
Dim var As Variant
Dim i As Integer
str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
var = Split(str, "!")
i = UBound(var) + 1
Debug.Print "First element: " & LBound(var)
Debug.Print "Last element: " & UBound(var)
Debug.Print "Quantity of elements: " & i
End Sub
It will print this output to the Inmediate window:
First element: 0
Last element: 7
Quantity of elements: 8
Also, if you are not sure that the first element (lbound) is 0, you can just use:
i = UBound(var) - LBound(var) + 1