Tag Archives: vba

Having hard time positioning pictures in Excel cell with vba

Last two days I had a hard time trying to figure out why my vba macro failed to position pictures in cells.
My goal was to add pictures of products loaded from external JPG files (previously resized to 64×64) to each row, so user can easily distinguish the product she is working with just by glancing.
To emmbed pictures into the file I used Shapes.AddPicture method. To properly position it within the cell I passed Left and Top paramters.

Set shp = targetSheet.Shapes.AddPicture( _
                    fileName:=picPath, LinkToFile:=False, SaveWithDocument:=True _
                    , Left:=picLeft, Top:=picTop, Width:=-1, Height:=-1)

By passing -1 to Width and Height parameters the picture preserved it’s original dimensions.

But no matter what parameters I passed to AddPicture method each next product was placed with a little offset from the top of the target cell. And each next product it was misplaced a little bit further to the bottom.
I was almost out of ideas when I understood that the zoom of the target sheet was set to 80, as it’s more was required for this report.
After setting it to 100 in vba macro before inserting pictures and then resetting it back to 80 I was able to properly position images within cells.
So here’s a little chunk of code that inserts pictures for me.

appWorkbooks.OpenText fileName:=m_picsDataFilePath, TextQualifier:=xlNone, DataType:=xlDelimited, Tab:=True, _
    FieldInfo:=Array( _
        Array(1, xlGeneralFormat_), Array(2, xlGeneralFormat_), Array(3, xlGeneralFormat_) _
    )
Set picsWorkbook = appWorkbooks(GetFName(m_picsDataFilePath))

targetSheet.Activate
ActiveWindow.Zoom = 100

plog ("Insert pictures")
picColumnIdx = m_targetDataMapper.GetIdx("V41")
Set workRange = targetSheet.Cells(1, picColumnIdx)
workRange.EntireColumn.NumberFormat = "0"
picLeft = workRange.Left + 2

Set workRange = Nothing

Set sourceSheet = picsWorkbook.Sheets(1)

rowIdx = templateRow + 1
maxRowIdx = templateRow + sourceRowCount
picRowIdx = 2

Do While (rowIdx <= maxRowIdx) ' And rowIdx < 100
    picPath = sourceSheet.Cells(picRowIdx, 1).value
    picTop = 0
    picTop = targetSheet.Cells(rowIdx, picColumnIdx).Top + 2
    ' plog (CStr(picLeft) & " " & CStr(picTop))
    If "" <> picPath Then
        ' picWidth = sourceSheet.Cells(picRowIdx, 2).value
        ' picHeight = sourceSheet.Cells(picRowIdx, 3).value

        Set shp = targetSheet.Shapes.AddPicture( _
            fileName:=picPath, LinkToFile:=False, SaveWithDocument:=True _
            , Left:=picLeft, Top:=picTop, Width:=-1, Height:=-1)
        shp.Placement = xlMoveAndSize
        Set shp = Nothing
    Else
        Set shp = targetSheet.Shapes.AddShape(msoShapeRectangle, _
            picLeft, picTop, 65, 68)
        
        With shp.Fill
            .ForeColor.RGB = RGB(255, 255, 255)
            .BackColor.RGB = RGB(255, 255, 255)
        End With
        shp.Line.Visible = msoFalse
        shp.Placement = xlMoveAndSize
        Set shp = Nothing
    End If
    picRowIdx = picRowIdx + 1
    rowIdx = rowIdx + 1
Loop
picsWorkbook.Close SaveChanges:=False
Set picsWorkbook = Nothing
ActiveWindow.Zoom = 80

Note the addition of the white rectangular shape for each missing picture to fully cover the cell. It solves the problem of stacking pictures when somebody filters products.
I was able to solve this problem, but I wonder how many other quirks does Excel have.

VBA: Run-time error 3001 Arguments Are Of The Wrong Type… when setting ADODB.Command object members

This forum post saved my day.
I was trying to run Oracle stored procedure with output parameters from Excel VBA with the following piece of code:


Dim cmd As Object
Dim resultSet As Object
Set cmd = CreateObject("ADODB.Command")
With cmd
.CommandText = "PK_AUTH.LOGON"
.NamedParameters = True
.Parameters.Append .CreateParameter("login", adVarChar, adParamInput, 50, login_)
.Parameters.Append .CreateParameter("pass", adVarChar, adParamInput, 50, pass_)
.Parameters.Append .CreateParameter("ldb", adVarChar, adParamOutput, 50)
.Parameters.Append .CreateParameter("pdb", adVarChar, adParamOutput, 50)
.CommandType = adCmdStoredProc
.ActiveConnection = GetConn_()
Set resultSet = .Execute
ldb_ = .Parameters.Item("ldb")
End With

And I always got Run-time error 3001 ‘Arguments Are Of The Wrong Type, Are Out Of The Acceptable Range, or are in conflict with one another’ upon invocation of

.CommandType = adCmdStoredProc

or

.Parameters.Append .CreateParameter(...)

no matter which statement I placed first.
After fighting for a while I found this post that stated that error is fired because of late binding of library references, so VB simply did not know of adCmdStoredProc and other constants
That meant that this error has nothing to do with ADODB or Ole or, I just said that it does not know the value of constant. Not very informative in fact…
So, I simply added


Const adVarChar As Long = 200
Const adParamInput As Long = &H1
Const adParamOutput As Long = &H2
Const adCmdStoredProc As Long = &H4

to the Sub header and everything worked fine. Constants are defined in c:Program FilesCommon FilesSystemadoadovbs.inc

VBA: Prototype Class than connects to oracle and checks if connection is up. Plus VBA singleton pattern

Here some prototyping code of a class that is able to connect to Oracle through OleDB and to check if the connection is up before doing some application logic. Class name is TUploadHelper.


Private m_conn As Object

Private Function GetConn_() As Object
If m_conn Is Nothing Then
Set m_conn = CreateObject("ADODB.Connection")
End If
Set GetConn_ = m_conn
End Function

Private Function Connected_() As Boolean
Dim recordSet As Object
Dim value As Long
Dim errCode As Variant
Dim errMsg As Variant

If Not PopErrors() Then On Error GoTo L_ERR_HANDLER

value = 0
Connected_ = False

Set recordSet = CreateObject("ADODB.Recordset")

Set recordSet.ActiveConnection = GetConn_()

recordSet.Open "select 1 as value_ from dual"
While Not recordSet.EOF
value = recordSet.Fields(0)
If 1 = value Then
Connected_ = True
GoTo L_CLEANUP
End If
Wend
' не вернулось ни одной записи
L_ERR_HANDLER:
errCode = Err.Number
errMsg = Err.Description
L_CLEANUP:
On Error GoTo 0
If 1 = recordSet.State Then
recordSet.Close
End If
Set recordSet = Nothing
End Function


Private Sub Class_Deinitialize()
If Not m_conn Is Nothing Then
If 1 = m_conn.State Then
m_conn.Close
End If
Set m_conn = Nothing
End If
End Sub

Private Function Authorized_() As Boolean
Authorized_ = False
End Function

Private Sub Connect_()
' Dim state_ As Variant
m_conn.Open "Provider=OraOLEDB.Oracle;Data Source=your_server.world;User ID=your_user;Password=your_pass;PLSQLRSet=1;"
' state_ = m_conn.State
End Sub

Public Sub Ut()
If Not Connected_ Then
Connect_
If Not Connected_ Then
End If
End If
End Sub

And here is module code that implements singleton pattern for TUploadHelper object.


'Singleton pattern
Private g_uploadHelper As TUploadHelper
Public Property Get GetUploadHelper() As TUploadHelper
If g_uploadHelper Is Nothing Then
Set g_uploadHelper = New TUploadHelper
End If
Set GetUploadHelper = g_uploadHelper
End Property