Dailycode.info

Short solution for short problems

vba ADO stored procedure in recordset 'Operation is not allowed when the object is closed'

I was trying to open a recordset from a stored procedure. I had the hardest time gettings this to work.

When me and my collegue Koen looked for solutions, Koen Goyens found this solution that worked: Add NextRecordset before you use the recordset, because the first recordset will always be empty. Here's a function that will return the recordset when you give a parameter and the name of the stored procedure:

 

' ------------------------------------------------------------------------------------------
' ---   Function opens a recordset using a Stored Procedure passed as parameter (sSQL)    ---
' ------------------------------------------------------------------------------------------
  Public Function OpenADOStoredProcedureRecordset(ByVal sSQL As String) As ADODB.Recordset

    Dim tmpConn As ADODB.Connection
    Dim RS As New ADODB.Recordset
    Dim cmd As ADODB.Command

    On Error GoTo RecordsetError

    ' --- Get the active connection (it will be opened if it's closed) ---------------------
    Set tmpConn = ADOConnection
    LogInfo "Started Stored Procedure: " & sSQL
    Set RS = New ADODB.Recordset ' --- create new ADO recordset struct. & get data ------
    RS.Open sSQL, tmpConn, adOpenUnspecified, adLockUnspecified

    Set OpenADOStoredProcedureRecordset = RS.NextRecordset
        
    LogInfo "End Stored Procedure: " & sSQL

    Exit Function

RecordsetError:
    AdoStatus = False
    AdoErr = Err.Number
    AdoErrDescr = Err.Description
    LogError "Error in OpenADOStoredProcedureRecordset: " & Err.Description
    Set RS = Nothing
    Set cmd = Nothing

  End Function

 The parameter sSql looks like this: exec spoMyStoredProc '0145698725658'

So when I call this function I get my result in the recordset and can start looping over it.


Unprotected Cells on a Protected worksheet

I was looking for a good way to set some cells editable in Excel in a worksheet that is completely protected. 

I call a function at the end of the action that protects the entire sheet:

Public Sub ProtectSheet(sWorkSheet As String)

 Worksheets(sWorkSheet).Protect Password:=XXxxXXxx, AllowFiltering:=True

End Sub

Now to prevent some cells to be protected, you just need to set the cells to Locked = False before you protect the worksheet.

'Make sure this cell doesn't get protected when you protect the sheet.

 Cells(iCnt, 3).Locked = False

Extract a number from a text cell in Excel (Without using VBA)

I needed to get the numbers from a cell that contains a number followed by text. I found this solution, assuming the text is in cell A1:

=REPLACE(LEFT(A1;LOOKUP(10;MID(A1;ROW(INDIRECT("1:30"));1)+0;ROW(INDIRECT("1:30"))));1;MIN(FIND(0;SUBSTITUTE(J1&0;{1;2;3;4;5;6;7;8;9};0)))-1;"")+0

Using the dutch settings, else replace the ; with ,

This function will give problems when numbers appear after the text. So this function is even better:

=LOOKUP(99^99;--("0"&MID(A1;MIN(SEARCH({0;1;2;3;4;5;6;7;8;9};A1&"0123456789"));ROW($1:$10000))))

It will get the leading numbers of a string in a cell for cell A1!

1354655 azezae will be 1354655

1354655 azezae 123 will still be 1354655!

Greets

Source


Inserting functions from .net into Excel. (VLOOKUP) "Exception from HRESULT: 0x800A03EC"

I got a small task to write a program that takes single language excel sheets and makes them multilanguage.
To accomplisch this we added a translation worksheet that will be filled with all translations of text in de excel worksheets for 4 different languages.
Then the text in the excel will be replaced with a VLOOKUP function that looks up the string in the Translation worksheet.
The program was ready in half a day, but then Excel strarted giving me a hard time.
If I tried to insert the VLOOKUP functino from code, it kept giving me an error. Inserting strings or even a SUM function was no problem, but the VLOOKUP wouldn't work. The functino looks like this: =VLOOKUP("Bath / Object";TRANSLATIONS;SPRACHE;FALSE).
This code was trying to insert the code in the cell where the text Bath / Object was:
 
xlApp.Worksheets.get_Item(index).Select();
string value = String.Format(@"=VLOOKUP(""{0}"";TRANSLATIONS;SPRACHE;FALSE)", str);
rangeSet.FormulaR1C1 = value;
First I tried all kinds of things to replace the quotes, but it didn't help. I tried setting the Value or Value2, Formula etc but it kept ginving me the error. Finally after a long search I recorded a macro in Excel and edited this macro and swaw that the Macro was using comma's (,) instead of colons (;).
So I changed the code looking like this and it works!!!!
xlApp.Worksheets.get_Item(index).Select();
string value = String.Format(@"=VLOOKUP(""{0}"",TRANSLATIONS,SPRACHE,FALSE)", str);
rangeSet.FormulaR1C1 = value;
The Nice error I got was: Exception from HRESULT: 0x800A03EC. Try to figure this out!

Serial communication in VB6

A friend just asked me how to use serial communication in VB6 or VBA.

So here's just a quick article on how to do this:

If you can't find the MSComm control, just add it this way:

First right click on the toolbar on the right side of the screen in VB:

Then click on: 'components'.

The following screen will appear where you can look for Microsoft Comm Control.

Now you can add this control to your forms.

Here is some code on how to start communication and how to process the recieved data:

startComPort(com_Scale, 1, "9600,e,7,2"))

 

This function starts the communication with the serial device: 

Private Function startComPort(com_obj As MSComm, i_Port As Integer, s_settings As String) As Boolean
  On Error GoTo startComPortERROR
  
  com_obj.Settings = s_settings
  com_obj.RThreshold = 1
  com_obj.SThreshold = 0
  com_obj.InputMode = comInputModeText
  com_obj.Handshaking = comNone
  com_obj.CommPort = i_Port
  com_obj.PortOpen = True
  
  startComPort = True
  
  Exit Function
startComPortERROR:
  startComPort = False
  DBG_ReportError Err.Number, Err.Description, "Weighstation.cls,startComPort", "", True
  Exit Function
End Function

Then when the serial device gets input this function is fired:

Private Sub com_Scale_OnComm()
  On Error GoTo com_OnCommERROR
Dim Text As String
  
  If com_Scale.PortOpen = True Then
                Text = com_Scale.Input
  End Select
  
...
  Exit Sub
com_OnCommERROR:
  If (Err.Number = 8021) And (com_Scale.PortOpen = True) Then
    com_Scale.PortOpen = False
  End If
  DBG_ReportError Err.Number, Err.Description, "Weighstation.cls,com_OnComm", "", True
  Exit Sub

 

Special greeting to Gustavo, a brother and colleague in Brazil...

Find strings in Excel sheet

How can we look up a string in an Excel sheet? With normal Excel code it is easy using the FIND function, but when you want to use a VBA function on all results of the find operation, you'll need a custom function:

Function FindAll(SearchRange As Range, FindWhat As Variant, _
    Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This returns a Range object that contains all the cells in SearchRange in which FindWhat
' was found. The parameters to the function have the same meaning as they do for the
' Find method of the Range object. If no cells were found, the result of this function
' is Nothing.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FoundCells As Range
Dim LastCell As Range
Dim FirstAddr As String
With SearchRange
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' In order to have Find search for the FindWhat value
    ' starting at the first cell in the SearchRange, we
    ' have to find the last cell in SearchRange and use
    ' that as the cell after which the Find will search.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set LastCell = .Cells(.Cells.Count)
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Do the initial Find. If we don't find FindWhat in the first Find,
' we won't even go into the code which searches for subsequent
' occurances.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
    LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
    ''''''''''''''''''''''''''''''
    ' Set the FoundCells range
    ' to the first FoundCell.
    ''''''''''''''''''''''''''''''
    Set FoundCells = FoundCell
    ''''''''''''''''''''''''''''
    ' FirstAddr will contain the
    ' address of the first found
    ' cell. We test each FoundCell
    ' to this address to prevent
    ' the Find from looping back
    ' through the range it has
    ' already searched.
    ''''''''''''''''''''''''''''
    FirstAddr = FoundCell.Address
    Do
        ''''''''''''''''''''''''''''''''
        ' Loop calling FindNext until
        ' FoundCell is nothing or
        ' we wrap around the first
        ' found cell (address is in
        ' FirstAddr).
        '''''''''''''''''''''''''''''''
        Set FoundCells = Application.Union(FoundCells, FoundCell)
        Set FoundCell = SearchRange.FindNext(after:=FoundCell)
    Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
End If
''''''''''''''''''''
' Return the result.
''''''''''''''''''''
If FoundCells Is Nothing Then
    Set FindAll = Nothing
Else
    Set FindAll = FoundCells
End If
End Function
 

This function returns an array of ranges containing the ranges where the searched string was in. After you can perform operations on the result values like this:

Private Sub FindAndDeleteCells()
    Dim SearchRange As Range
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim FindWhat As Variant
    Dim MatchCase As Boolean
    Dim LookIn As XlFindLookIn
    Dim LookAt As XlLookAt
    Dim SearchOrder As XlSearchOrder
    
    ''''''''''''''''''''''''''
    ' Set the variables to the
    ' appropriate values.
    ''''''''''''''''''''''''''
    Set SearchRange = ThisWorkbook.Worksheets(1).Range("A1:D20")
    FindWhat = "Large"
    LookIn = xlValues
    LookAt = xlPart
    SearchOrder = xlByRows
    MatchCase = False
    
    '''''''''''''''''''
    ' Search the range.
    '''''''''''''''''''
    Set FoundCells = FindAll(SearchRange:=SearchRange, FindWhat:=FindWhat, _
        LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
    
    ''''''''''''''''''''''
    ' Display the results.
    ''''''''''''''''''''''
    If FoundCells Is Nothing Then
        Debug.Print "No cells found."
    Else
        For Each FoundCell In FoundCells.Cells
            ' Now we delete the cell and the 3 cells on the right
            FoundCell.Cells.Activate
            FoundCell.Cells.Clear
            FoundCell.Offset(0, 1).Activate
            FoundCell.Offset(0, 1).Clear
            FoundCell.Offset(0, 2).Clear
            FoundCell.Offset(0, 3).Clear
            'Delete the Cells
            ' If you only want ot delete the cells, then use this code:
            'FoundCell.Rows.Delete
            
            'Delete the entire row
            'If you want to delete the entire row then use this code:
            Dim i As Long
            For i = FoundCell.Rows.Count To 1 Step -1
                    FoundCell.Rows(i).EntireRow.Delete
            Next i
        Next FoundCell
    End If
End Sub