Posts by Ludo_Soete

Ludo_Soete · Dec 24th 2021

Thanks Gijsmo, it does the trick.

Merry Christmas & Happy 2022

Best regards,

Ludo

Ludo_Soete · Dec 22nd 2021

Quote from royUK

An example workbook would help. Which line errors?

It doesn't make sense declaring a variable for the CurrentRegion.

Hi Roy

Find an example workbook in the attachement.

It fails in following line:

.RemoveDuplicates Columns:=Array(ColumnNumbers), Header:=xlYes '<< Run-time error 13

Is also noted in my first question, last code example.

I use the currentregion to determine how many columns I have in the data file and use this number in the Case statement.

More info:

I work for the aviation bussiness and every cocpit monitor goes into a climate chamber where a temperature, power on/off & vibration is applied using a profile and creates a log file.

During this profele time (typical 4hours), a test program runs and create a log file.

After the profile is applied, I readout the minimum & maximum temperartures from the climate chamber log file AND the different temperatures from the test program.

Because every TYPE of monitor is different, the number of temperature sensors in the cocpit monitor is also variable.

Thats what you can see in my initial question, the upper code snipset. (35,36,37,38,39 & 45 columns).

The idea is to place those column numbers into the TYPE monitor configuration file so that the VBA code could be generic for any number of columns.

making it a lot easyer to configure this way than changing the VBA code.

Anyhow, thanks for looking at it.

best regards,

Ludo

Ludo_Soete · Dec 22nd 2021

Hi,

I'm writing data into an Excel workbook, after writing the data I'll check for duplicates and remove them if found.

For this purpose, I'm using the Range.RemoveDuplicates in my project but want it to be more flexible (Excel 2016).

As you can see below, I have different cases and columns to check for duplicates.

Everything is now hardcoded in the project, but like to prevent this and define the Columns array as a variable.

I retire by the end of next year, and If a new case is needed, it can give a problem for people not familiar with VBA.

See my test code on the bottom and can't get it working ( Run-time error 13).

It doesn't matter If i define the ColumnNumbers As Variant or as String

If I can get this up and running, then It don't need to be hardcoded in the project, and can I place the column numbers into a configuration file (variable).

Can this be done or not, or do i need a complete different approach to obtain the same result? If so, how to do it?

To all: Merry Christmas & Happy 2022

Best regards,

Ludo

Code

'Original code snipset
'********************************************
'remove eventual duplicate entries
'we don't take the columns 5,7 & 8 into account
'********************************************
Set rngDataRange = .Cells(1, 1).CurrentRegion
With rngDataRange
Select Case .Cells(1, 1).CurrentRegion.Columns.Count
Case 35 
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35), Header:=xlYes
Case 36 '
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36), Header:=xlYes
Case 37 
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37), Header:=xlYes
Case 38 '
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38), Header:=xlYes
Case 39
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39), Header:=xlYes
Case 45
.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45), Header:=xlYes


End Select
End With

Display More

Here below is my test code generating a Run-time error 13

Code

Option Explicit
'TEST CODE
Sub testDuplicates()
    Dim rngDataRange As Range
    Dim v2 As Variant
    Dim ColumnNumbers As Variant        'String
    
    ColumnNumbers = "1, 2, 3, 4, 6, 9, 10, 11, 12, 13, 14"
    
        Set rngDataRange = ActiveSheet.Cells(1, 1).CurrentRegion
        With rngDataRange
            Select Case .Cells(1, 1).CurrentRegion.Columns.Count
                Case 11
                    .RemoveDuplicates Columns:=Array(ColumnNumbers), Header:=xlYes    '<< Run-time error 13
'
            End Select
        End With

End Sub

'*******************************************************************************

Display More

Ludo_Soete · Dec 14th 2017

Hi,

Hopefully I post it in the right forum.

I have a userform in a Word 2010 application with a webbrowser object in it.
Before i show this userform, i create the needed HTML code to open in the webbrowser.
The HTML code represent a labelsheet (A4), and the table rows & columns varry with the selected label sheet.
Obvious, this depends on the number of labels across and down on the label sheet.

In fact, it's only a table with a button in each table cell.

Because there's no Click event in the webbrowser object, I can't get its Row / Column value when I click in a table cell.

The probem i have is that i can't figure out what the HTML syntax is to run a subroutine from within the same userform.
The purpose is to retreive the table row & column number when i click a button.

the OnClick line give me always an error like:
Error 20 Permission denied
line: 45
char: 30
error: Expected ";"
code: 0
URL: .....

when i remove this line i don't get this error anymore.

I would appreciate it if anyone can help me to solve this problem.

here's part of the generated HTML code:

HTML

<!DOCTYPE html>
<html>
<head>
<style>
* {
    padding: 0;
    margin: 0;
}




body {
    background-color: linen;
    margin: 1em;        
}




table tr td { text-align: center; }
/* Selected cell background = green */
table tr td.SelectedCell { 
    background-color: #4CAF50;
    font-size: 1em;
    color: Blue;
    height: 24px;
    width: 47px;
    text-align: center;
    border: 1px solid #FF0000;
    }
/* Empty cell background = Gray */
table tr td.EmptyCell {
    background-color: #808080;
    font-size: 1em;
    color: Red;
    height: 24px;
    width: 47px;
    text-align: center;
    border: 1px solid #FF0000;
    }
</style>
</head>
<body>
<table>
    <tr>
    <td class= "SelectedCell">
        <input type='button'; 
        onClick='Application.Run "'New Label printer -6AB.docm'!StartHere.GetSelectedTableCellCoordinates"';     [B][COLOR=#FF0000]<<< Error here[/COLOR][/B]
        class='button';
        value=☺>
    </td>
    <td class= "EmptyCell">
        <input type='button'; 
        onClick='Application.Run "'New Label printer -6AB.docm'!StartHere.GetSelectedTableCellCoordinates"';    [B][COLOR=#FF0000]<<< Error here[/COLOR][/B]
        class='button';
        value=☹>
    </td>
    <td class= "EmptyCell">
        <input type='button'; 
        onClick='Application.Run "'New Label printer -6AB.docm'!StartHere.GetSelectedTableCellCoordinates"';    [B][COLOR=#FF0000]<<< Error here[/COLOR][/B]
        class='button';
        value=☹>
    </td>
    <td class= "EmptyCell">
        <input type='button'; 
        onClick='Application.Run "'New Label printer -6AB.docm'!StartHere.GetSelectedTableCellCoordinates"';    [B][COLOR=#FF0000]<<< Error here[/COLOR][/B]
        class='button';
        value=☹>
    </td>
</tr>

Display More

and here's the test code from the Word subroutine that need to run when click on a button (need to be tuned).

Code

Sub GetSelectedTableCellCoordinates()
'get the selected HTML table Row & Column values
'and place them in the apropriate textboxes


    With frmLabelPosition
        .tbRow = gintTableRow
        .tbColumn = gintTableColumn


    Debug.Print "Table Row = " & .tbRow
    Debug.Print "Table Column = " & .tbColumn
    End With
End Sub

Display More

Ludo_Soete · Jul 30th 2017

Re: Selected item in listbox not highlighting

Quote from KjBox;795758
One way is to do the following:

1. Use an unused cell on any sheet, make it a Named Range with the name "ListIndex", enter -1 in that cell ( you can set the font colour to the same as fill colour so that the value will not show).
2. Use this as the code that launches the user form
Code
Sub LoadForm()
    With UserForm1  '// Change name of user form to suit
        .lbPrinterList.ListIndex = Range("ListIndex")
        .Show
    End With
End Sub
3. Use this as the lbPrinterList Click event code
Code
Private Sub lbPrinterList_Click()
    
[ListIndex] = ListBox1.ListIndex
End Sub

Hi
Thanks for the answer.
Sorry for the late reply, I'm on holiday for the moment.
Will give it a try when back at work.

best regards,
Ludo

still searching for the Star ....

Ludo_Soete · Jul 11th 2017

Hi,

I have a userfrom (Word 2010) with a listbox (lbPrinterList) and a command button (cmdClose).
In the Initialize event, i read the previous selectted listindex from the local registry.
I create a list of the the installed printers and
When running it the first time, I'll set the default listindex to -1 (nothing selected).
Then I create a list of installed printers and populate the listbox with it.

When I click then on a listitem (listbox click event ) I save the listbox listindex to the local registry.

Once i run the initialize event again i'll read the previous listindex back from the registry, but the listitem will not highlight, no matther what I try.

What am I doing wrong ?
Hope someone will bring up a solution.

Here's the full userform code + the printerlist code (source: Chip Pearson)

Best regards,
Ludo

Code

Private Sub cmdClose_Click()
    Unload Me
End Sub




Private Sub lbPrinterList_Click()




    If bInitializeUserForm = True Then Exit Sub




    sSelectedPrinter = Me.lbPrinterList.List(Me.lbPrinterList.ListIndex)
    
'save selected printer list index to the local PC registry
    SaveSetting AppName:=sAppName, Section:=sSECTION_PRINT, Key:=sKEY_DEFAULT_PRINTER, setting:=Me.lbPrinterList.ListIndex
'
    Me.cmdClose.Enabled = True
End Sub




Private Sub lbPrinterList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    lbPrinterList_Click
    Unload Me
End Sub




Private Sub lbPrinterList_Enter()
    Me.lbPrinterList.BackColor = cYELLOW
End Sub




Private Sub lbPrinterList_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'check if printer selected from printerlist
    If Me.lbPrinterList.ListIndex <> -1 Then
    sSelectedPrinter = Me.lbPrinterList.List(Me.lbPrinterList.ListIndex)




    Me.lbPrinterList.BackColor = cWHITE
        With Me.cmdClose
            .Enabled = True
            .SetFocus
        End With
    End If
End Sub




Private Sub UserForm_Initialize()
    Dim lListIndex As Long
    
    bInitializeUserForm = True
    
    lListIndex = GetSetting(AppName:=sAppName, Section:=sSECTION_PRINT, Key:=sKEY_DEFAULT_PRINTER, Default:=-1)
    
    If bDuplexPintDllFound = True Then
        PrinterDuplex_ListPrinters
    Else
        CreateInstalledPrinterList
    End If
'
    With Me
'center userform on screen
        .Left = (Application.UsableWidth - Me.Width) / 2
        .Top = (Application.UsableHeight - Me.Height) / 2
        .cmdClose.Enabled = False
    End With
    
'highlight the selected printer in the listbox
    With Me.lbPrinterList
        .ListIndex = lListIndex 'GetSetting(AppName:=sAppName, Section:=sSECTION_PRINT, Key:=sKEY_DEFAULT_PRINTER, Default:=-1)
        .Selected(lListIndex) = True
    End With
    bInitializeUserForm = False
'
End Sub




Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode <> vbFormCode Then
        Cancel = True
        bCancelPrinting = True
    Else
        bCancelPrinting = False
    End If
End Sub


Sub CreateInstalledPrinterList()
'http://www.cpearson.com/excel/GetPrinters.aspx
'modified to show only the installed network printers
    Dim Printers() As String
    Dim NetworkPrintersOnly() As String
    Dim N As Long
    Dim s As String
    Dim i As Long
    Dim iRow As Integer
    
    
    Printers = GetPrinterFullNames()
    For N = LBound(Printers) To UBound(Printers)
        If Left(Printers(N), 1) = "\" Then
            i = i + 1
            ReDim Preserve NetworkPrintersOnly(i)
            NetworkPrintersOnly(i) = Printers(N)
        End If
    Next N
    frmSelectPrinter.lbPrinterList.List = NetworkPrintersOnly




    End Sub

Display More

Ludo_Soete · Mar 24th 2016

Re: Can't select Listbox selection

Hi,

it seems to be that i found the solution.
I need to use the Selected property of the listbox.

here's the code of the modified textbox events using the Selected property in the userform frmSelectLabels:

[code]
Private Sub tbSearchLocation_Change()
Dim lLocCount As Long 'number of warehouse locations in the listbox
Dim SearchCriteria As String 'search string
Dim iLength As Integer 'length of the search string
Dim L As Long 'counter

lLocCount = Me.ListBox1.ListCount 'lLocCount= the number of locations
With Me.tbSearchLocation
SearchCriteria = .Value
iLength = Len(.Value)
'if next character entered for search, reset the bMatchFound flag
If iSearchStringLenth < iLength Then
bMatchFound = False
End If
iSearchStringLenth = iLength 'save searchstring length for next search
.Value = UCase(.Value)
End With
'loop through the listbox for a match
For L = 0 To lLocCount - 1
If bMatchFound = True Then Exit Sub '24/03
With Me.ListBox1
If Left(.List(L), iLength) = SearchCriteria Then
.ListIndex = L 'highlight the match in the listbox
.Selected(L) = True
lMatchListIndex = L 'save the listindex
bMatchFound = True
End If
End With
Next
End Sub

Private Sub tbSearchLocation_Enter()
With Me.tbSearchLocation
.BackColor = cYellow
End With
End Sub

Private Sub tbSearchLocation_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.tbSearchLocation
.BackColor = vbWhite
End With
With Me.ListBox1
.Selected(lMatchListIndex) = True
End With
bMatchFound = True
End Sub
[\code]

and here's the code from the listbox events
[code]
Private Sub ListBox1_Change()
Dim lCntr As Long
Dim lCntr2 As Long
Dim lSelections As Long 'number of selected items in listbox (multi select)

Select Case PrintMode
'print single selection
Case Is = cPrintSingleLabel
ReDim Preserve sLocations(0)
'we get only the selection if an item from the listbox is selected
'then we enable the 'Verder' button.
With frmSelectLabels
If .ListBox1.ListIndex <> -1 Then
sLocations(0) = .ListBox1.List(frmSelectLabels.ListBox1.ListIndex)
.cmdNext.Enabled = True
End If
End With
'print selection
Case Is = cPrintSelection
For lCntr = 0 To frmSelectLabels.ListBox1.ListCount - 1
If frmSelectLabels.ListBox1.Selected(lCntr) = True Then
ReDim Preserve sLocations(lCntr2)
sLocations(lCntr2) = frmSelectLabels.ListBox1.List(lCntr)
lCntr2 = lCntr2 + 1
frmSelectLabels.cmdNext.Enabled = True
End If
Next
End Select
End Sub

Private Sub ListBox1_Enter()
If bMatchFound = True Then Exit Sub
With Me.ListBox1
.BackColor = cYellow
End With
End Sub

Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.ListBox1
.BackColor = cWhite
End With
bMatchFound = False
End Sub
[\code]

following variables are public
[code]
Public Const cYellow = &H80FFFF
Public Const cWhite = &H80000005

Public lMatchListIndex As Long 'listbox1 list index for search match
Public bMatchFound As Boolean 'True if a match found
[\code]

And the variable iSearchStringLenth is defined ON TOP of the userform frmSelectLabels.
[code]
Option Explicit
Dim iSearchStringLenth As Integer
[\code]

thanks for looking at it.

Ludo

Ludo_Soete · Mar 23rd 2016

Re: Can't select Listbox selection

O.K.

attached you'l find a derived EXEL file.
copied the code from Word to a Excel file.

the file 'Locaties.xlsx' contains the warehouse locations.
I reduced the list to 3000 locations instead of 6336 locations to get a smaller file size.

the file Warehouse locations2.xlsm is the 'application'

when you open this file in Excel, it adds a new tab called "Warehouse Labels" in the ribbon next to the Home tab.
click on the "Print Labels" button.
the code will check if the full path & filename to the file "Locaties.xlsx" exist in the local registry, if not, you have to place it in the upper textbox from the userform 'frmLabelLocFileName'.
place in the second textbox following string: alle lokaties in 1 file
this is the sheet name where the warehouse locations are read from (column F).
click save & close.

the code will import the label locations from the file 'Locaties.xlsx, sheet 'alle lokaties in 1 file'.

you can enter a search string in the 'Search Location' textbox. The listbox will follow the input from the textbox, but once you click on the highlighted item in the listbox, it shows the first 24 locations, and not the one selected.

to stop, click the close button.
don't try to print, because this code is still for use with Word.

thanks for looking at it.

best regards,
Ludo

Ludo_Soete · Mar 23rd 2016

Re: Can't select Listbox selection

Hi,

see my next post

Ludo

Ludo_Soete · Mar 22nd 2016

Hi,

I have a userform populated with over 6000 warehouse locations.
i added a textbox where i enter a warehouse location for easy lookup in the listbox.
when entering text, i'll search a match in the listbox.
so far so good.
there are 24 'locations' visible in the listbox.
problem start when a match found, and i click on the highlighted 'location' in the listbox, the listboxt start showing the locations from the first 'location' in the list, and not the selected one.
example: the match found is the 512 'location' in the list, but it shows 'location' 1 to 24 after I click on the 512-th item, or try to scroll down with the listbox scrollbar.

here's my code for the textbox where i enter the search string to look for in the listbox.

Code

Private Sub tbSearchLocation_Change()
    Dim lLocCount As Long
    Dim SearchCriteria As String
    Dim iLength As Integer
    Dim sDummy As String
    
    lLocCount = Me.ListBox1.ListCount       'lLocCount= the number of locations
    With Me.tbSearchLocation
        .Value = UCase(.Value)
        SearchCriteria = .Value
        iLength = Len(.Value)
    End With
'loop through the listbox for a match
    For l = 0 To lLocCount - 1
        With Me.ListBox1
            If Left(.List(l), iLength) = SearchCriteria Then
                 .ListIndex = l      'highlight the match in the listbox
                 bMatchFound = True
                Exit Sub
            End If
        End With
    Next
End Sub




Private Sub tbSearchLocation_Enter()
    With Me.tbSearchLocation
        .BackColor = cYellow
    End With
End Sub




Private Sub tbSearchLocation_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With Me.tbSearchLocation
        .BackColor = vbWhite
    End With
    With Me.ListBox1
        .BackColor = cYellow
        .ListIndex = l
    End With
    bMatchFound = True
End Sub

Display More

and here's the code from the listbox.

Code

Private Sub ListBox1_Change()
    Dim lCntr As Long
    Dim lCntr2 As Long
    Dim lSelections As Long         'number of selected items in listbox (multi select)




    Select Case PrintMode
        Case Is = cPrintSingleLabel
            ReDim Preserve sLocations(0)
'we get only the selection if an item from the listbox is selected
'then we enable the 'Next' button.
            With frmSelectLabels
                If .ListBox1.ListIndex <> -1 Then
                    sLocations(0) = .ListBox1.List(frmSelectLabels.ListBox1.ListIndex)
                    .cmdNext.Enabled = True
                End If
            End With
   
        Case Is = cPrintSelection
            For lCntr = 0 To frmSelectLabels.ListBox1.ListCount - 1
                If frmSelectLabels.ListBox1.Selected(lCntr) = True Then
                    ReDim Preserve sLocations(lCntr2)
                    sLocations(lCntr2) = frmSelectLabels.ListBox1.List(lCntr)
                    lCntr2 = lCntr2 + 1
                    frmSelectLabels.cmdNext.Enabled = True
                End If
            Next
    End Select
End Sub




Private Sub ListBox1_Enter()
    If bMatchFound = True Then Exit Sub
    With Me.ListBox1
        .BackColor = cYellow
    End With
End Sub




Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With Me.ListBox1
        .BackColor = cWhite
    End With
    bMatchFound = False
End Sub

Display More

what i like to obtain is, when i find a match, then click on the highlighted 'location' in the listbox (or scroll down with the listbox scrollbar), that the listbox doesn't get 'reset' to the first 'location' in the list.

the variables l and bMatchFound are Public.

I'm convinced that it can be done, just don't know how to get it working.
Any help welcome.

best regards,
Ludo

Ludo_Soete · Jul 1st 2015

Re: Autozise textbox height for multirow input

Hi again,

I renamed the .ini file to .txt - works fine.
the XML file could be uploaded but there's a warning sign.
but i couldn't upload the .dotm file, even if i rename the .dotm file to .txt or .xls or whatever, it won't work.
i get following error message:
500[IOErrorEventtype = "ioError" bubbles=false cancelable=false eventphase=2 text= "Error #2038"]

so, I decided to make some re-arrangements in the userform, made the textbox a lot larger in height to be able to enter 8 text lines before the text disappears as described in previous messages.
I can live with this approach.

I did spent a few hours on this approch to see that it finally won't work at all.

I'm sorry for your lost time, but was convinced that it would be a nice approach, but the odds are against me.

anyhow, thanks a lot for reading the question and wanting to look at it.
I would say: issue closed.

best regards,
Ludo

Ludo_Soete · Jul 1st 2015

Re: Autozise textbox height for multirow input

Hi,

thanks for the request, but i can't send you the file.
i need to confess that it's not a Excel workbook, but a Word Add-in (.dotm).
when trying to attach the file, i get a invalid file message (when i hoover over the RED exclamation mark)
note also that it need a second file, namely the description of custom labels.

reason i did ask it here is :
1) there's no specific WORD forum here (or i missed it)
2) because userforms and their objects behave identical in each OFFICE program (Word, Excel, Powerpoint, ..),.

are there any ideas where i have to look at?
Here are at least the Categorized Behaviour properties for the specific textbox:

AutoSize: False
AutoTab: False
AutoWordSelect: True
Enabled: True
EnterKeyBehaviour: False
HideSelection: True
IntegralHeight: True
Locked: False
MaxLength: 0
MultiLine: True
SelectioMargin: False
TabKeyBehaviour: False
TextAlign: 1 - fmTextAlignLeft
WordWrap: False

sorry if i mislead you.

anyhow thanks for the reply.
Ludo

Ludo_Soete · Jul 1st 2015

Hi experts,

I do have a little problem to keep ALL the entered text visible in a textbox, setup for multiline input.
After initializing the userform, i have a textbox with a height of 20 and a font = Tahoma / Bold / size 10.
The width of the textbox = 186

After entering the first text line (3 characters for testing), i press the Ctrl + Enter key, so that i go to the next line (crlf).
Now i notice that the first line of text is moving a bit up, but still visible.
if I enter now the second line of text, the first entered text is completely moved up and no longer visible, even due to the fact that I enlarge the textbox heigth in the KeyDown event.
The more text lines i add the more likely that the second line also disapears from the textbox.

I tried to set the textbox Autosize to True, but it act the same. First line of text is moving up and no longer visible.
Is it uberhaupt possible to keep ALL the entered text in the textbox visible, and not moving up?
if so, how can it be done?

following code are the used events for this textbox:

Code

Private Sub tbLabelText_Enter()
    With Me
        .tbLabelText.BackColor = cYellow
    End With
End Sub




Private Sub tbLabelText_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With Me
        .tbLabelText.BackColor = cWhite
        sText = .tbLabelText.Text
        .cmdFillLabels.Enabled = True
    End With
End Sub


Private Sub tbLabelText_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'if multiline text, we enlarge the textbox height
    If KeyCode = 13 Then
        With Me
        .tbLabelText.Height = .tbLabelText.Height + Int(.tbLabelText.Font.Size) + 1
        End With
    End If
End Sub

Display More

Best regards and thanks for any help.
Ludo

Ludo_Soete · Jun 1st 2015

Re: Userform color to RGB values

@ Rory,

Thanks a lot for the fast reply.
it works great.
the returned values for the &H8000000F = 240,240,240 -> pritty close to the guessed 242,242,242 values.

pike,

Will read this too, thanks too for the link.

Best regards,
Ludo

Ludo_Soete · Jun 1st 2015

Hi,

I'm looking for a way (function) to convert the userform back color(example: &H8000000F) to RGB values.
Reason is that i use sometimes a picture in a Userform button or Userform image.
VBA doesn't accept a PNG picture but a BMP.
BMP doesn't support tranparent colors, so i want to set the surrounding color (set as transparent color in GIF & PNG pictures) as close as the Userform backcolor, using Paint -> Edit Colors.

I guess there's more than the RGB values only in this value ,i count 8 digits, but every color is represented by 2 digits (Decimal :0 -> 255 = Hex: 00 to FF).
where are the remaining 2 digits used for?

Any help in this mystery of colors is appreciated.
For the moment, i'm just guessing the RGB values and use 242,242,242 .
it's pritty close the the wanted color, but i'm wondering if this could be calculated using a function.

Thanks for any help.

Best regards,
Ludo

Ludo_Soete · Aug 26th 2014

Re: Write to .ini file fails - cause?

sorry for the post, it seems to be that i don't have permission on this folder.
So used that everything works imediately that i didn't think that there could be restrictions on the folder level.

Ludo

Ludo_Soete · Aug 26th 2014

Re: Write to .ini file fails - cause?

Hi,

after some browsing on the net i found following code to return the error message string:

Code

Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
    Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
    Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Sub ShowLastError(sTyphoonManagerIniFullName As String, cSectionTyphoonManager As String, cKeyTyphoonManagerLastPRf As String, sPrfFileName As String)
    Dim lngStatus As Long
    Dim strMessage As String
    
    strMessage = Space$(512)
    lngStatus = SaveIniKey(sTyphoonManagerIniFullName, cSectionTyphoonManager, cKeyTyphoonManagerLastPRf, sPrfFileName)  'write new value into ini file
        If lngStatus = 0 Then
            lngStatus = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0, Err.LastDllError, 0, strMessage, Len(strMessage), 0)
            Debug.Print strMessage
        End If
End Sub

Display More

the returned message is: Access is denied.

Any one a clue why the access is denied?

Thanks in advance.
Ludo

Ludo_Soete · Aug 26th 2014

Hi,

I'm using for a while succesfull API calls to read/write to .ini files.
now i would like to manipulate a certain ini file, but it won't change the value after a SaveIniKey operation.
question now is what could cause this behaviour?

here's the code i use to read/write to the ini file

Code

Public Function SaveIniKey(ByVal iniFileName As String, ByVal strSection As String, ByVal strKey As String, ByVal strValue As String) As Boolean
'save a value to a .ini file
    Dim lngValid As Long
    Dim WritePrivateProfileString32 As Boolean
    On Error Resume Next
    lngValid = WritePrivateProfileStringA(strSection, strKey, strValue, iniFileName)
    If lngValid > 0 Then WritePrivateProfileString32 = True
    On Error GoTo 0
End Function
'-------------------------------------------------
Sub ChangeTyphoonManagerIniFile(sTyphoonManagerIniFullName As String, cSectionTyphoonManager As String, cKeyTyphoonManagerLastPRf As String, sPrfFileName As String)
    Dim sfName As String
    
    sfName = sPrfFileName
    
    Debug.Print GetIniKey(sTyphoonManagerIniFullName, cSectionTyphoonManager, cKeyTyphoonManagerLastPRf)
    SaveIniKey sTyphoonManagerIniFullName, cSectionTyphoonManager, cKeyTyphoonManagerLastPRf, sfName 'write new value into ini file
    Debug.Print GetIniKey(sTyphoonManagerIniFullName, cSectionTyphoonManager, cKeyTyphoonManagerLastPRf)
End Sub

Display More

As you can see, i use the same variables for reading & writing to the ini file, with the exeption of the sfName variable for writing.
sfName could be : \\Bvwsrv01\bvw\AV\Operations\HASS\6. Profiles\1. DU8x5\DU8x5_32G_V1_00.prf

The first Debug.Print line returns me: /X/Operations/HASS/6. Profiles/2. KDU1080_1500/Final_HASS_KDU1080_15G_V4_00.prf
the second Debug.Print line returns me the same string, even that the variable sPrfFileName = \\Bvwsrv01\bvw\AV\Operations\HASS\6. Profiles\1. DU8x5\DU8x5_32G_V1_00.prf

lngValid returns 0
the file attributes Hidden & Read-only arent NOTchecked.

here's a snipset of the ini file i want to manipulate:

Code

[OVSconfig]
VibHighLim=100.000000
VibBackupLim=100.000000
OPCGroupWriteDelay=25.000000
ProfilePanelOpen=FALSE
LastPRF="/X/Operations/HASS/6. Profiles/2. KDU1080_1500/Final_HASS_KDU1080_15G_V4_00.prf"     < need to change this line
PVChangeLim=30000.000000
CVStepSize=30.000000
LastLogFile="/C/Program Files/Typhoon Manager/LOG/KDU1080 25-08-2014 1.csv"
SoftwareVer="Typhoon Manager Software Version 5.03.02"
chksum=6B5175616C4D6172
SimMode=FALSE

Display More

Any idea why this isn't working?
Possible that any file attributes that prevent the file to change?

best regards,
Ludo

Ludo_Soete · Aug 22nd 2014

Re: Problem with Class module

Quote from S O;724065
Should it not be
Code
QualMarkProfile.Add ThisSeq
instead? I don't see a "QualMarkSequences" declared anywhere?

Thanks for your reply.

I've also been looking around and this is what i have: my first working class module.

First mistake was that i placed my declaration of the classes above the API declaration
Changed it and needed to add the second class declaration too like:

Code

Option Explicit
Option Private Module








Public Declare Function w32_GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Const cDebug As Boolean = True           'TRUE for debug purpose, FALSE for runtime




'public custom Class modules
Public QualMarkProfile As clQMProfileSequences  'Declares QualMarkProfile as a clQMProfileSequences class = collection of clQMProfileSequence   classes
Public QmSeq As clQMProfileSequence              'Declares QmSeq as a clQMProfileSequence  class

Display More

the Continue button has now following code

Code

Private Sub cmdContiniue_Click()
    Dim sSelectedUnitName As String




'place selected unit type into sSelectedUnitName before we clear ALL other variables
    sSelectedUnitName = sUnittype(0)
'Clear Public Variables
    ClearPublicVariables
'reset the unit value in array location sUnittype(0)
    sUnittype(0) = sSelectedUnitName
'
    LoadIniFileSettings sSelectedUnitName
    sPrfFileName = ""
    sPrfFileName = ThisWorkbook.Sheets("definitie").Range("profilepath")
    sPrfFileName = sPrfFileName & "\" & ThisWorkbook.Sheets("definitie").Range("profilename")
    LoadPrfFile sPrfFileName




    Set QualMarkProfile = New clQMProfileSequences
    QualMarkProfile.CreateClassCollection
    
    frmUnitData.Show
End Sub

Display More

and the class clQMProfileSequences has now following code in it

Code

Option Explicit




Private c_ProfileSequences As Collection
Private mcTemplate As String
Private p_Name As String




Private Sub Class_Initialize()
    Set c_ProfileSequences = New Collection
End Sub




Private Sub Class_Terminate()
    Set c_ProfileSequences = Nothing
End Sub




Function NewEnum() As IUnknown
    Set NewEnum = c_ProfileSequences.[_NewEnum]
End Function




Public Function Add(ByRef mPrfSeq As clQMProfileSequence)
    c_ProfileSequences.Add mPrfSeq, mPrfSeq.Seq_Number_String
End Function


Sub CreateClassCollection()
'we fill the Class clQMProfileSequence with  the profile Objects.
    Dim lCntr As Long
    Dim lLastRow As Long
    Dim lRowOffset As Long
    Const cSeqRowOffset As Integer = 28
    Dim QmSeq As clQMProfileSequence
    
    Dim wsPrfData As Worksheet
    
    Set QualMarkProfile = New clQMProfileSequences
    Set wsPrfData = ThisWorkbook.Sheets("Profile Data")




    With wsPrfData                                          'ThisWorkbook.Worksheets("Profile Data")
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For lCntr = 1 To lLastRow Step cSeqRowOffset
            Set QmSeq = New clQMProfileSequence
            QmSeq.Seq_Number_String = .Cells(lCntr, "A").Value
            QmSeq.Seq_Type_String = .Cells(lCntr + 1, "A").Value
            QmSeq.Dwell_Time_String = .Cells(lCntr + 5, "A").Value
            QmSeq.Temp_In_String = .Cells(lCntr + 7, "A").Value
            QmSeq.End_Temp_String = .Cells(lCntr + 8, "A").Value
            QmSeq.Temp_Trans_Dur_String = .Cells(lCntr + 10, "A").Value
            QmSeq.Start_Vib_String = .Cells(lCntr + 11, "A").Value
            QmSeq.End_Vib_String = .Cells(lCntr + 12, "A").Value
            QmSeq.Vib_Trans_Dur_String = .Cells(lCntr + 14, "A").Value
            QmSeq.SSR_Value_String = .Cells(lCntr + 22, "A").Value
            QmSeq.SSR_Index_String = .Cells(lCntr + 25, "A").Value
            QmSeq.Last_SSR_String = .Cells(lCntr + 27, "A").Value
            QualMarkProfile.Add QmSeq
        Next lCntr
    End With
End Sub


'more code follows in the clQMProfileSequences class

Display More

It works now as desired.

I know it's possible to put CreateClassCollection in the class initialize sub, but that's my next challenge.
I'm already happy that this one works.

Thanks for your remark, this was also a bug.

Best regards,
Ludo

Ludo_Soete · Aug 22nd 2014

Hi,

I'm trying to create my first class module(s).

First i got my Sub CreateClassCollection() routine in a regular module.
It worked perfect

Now i want to move it into the clQMProfileSequences class.

I have 2 classes, one called clQMProfileSequence, containing the individual data and a class clQMProfileSequences, containing the collection of clQMProfileSequence.

in a regular module i have following code on top before my subs:

Code

Option Explicit
Option Private Module


Public QualMarkProfile As clQMProfileSequences  'Declares QualMarkProfile as a clQMProfileSequences class

I have also a userform with 3 buttons & a listbox.
when i click on the 'Continue' button, following code is executed where i want to 'populate' the class collection:

Code

Private Sub cmdContiniue_Click()
    Dim sSelectedUnitName As String
'place selected unit type into sSelectedUnitName before we clear ALL other variables
    sSelectedUnitName = sUnittype(0)
'Clear Public Variables
    ClearPublicVariables
'reset the unit value in array location sUnittype(0)
    sUnittype(0) = sSelectedUnitName
'
    LoadIniFileSettings sSelectedUnitName
    sPrfFileName = ""
    sPrfFileName = ThisWorkbook.Sheets("definitie").Range("profilepath")
    sPrfFileName = sPrfFileName & "\" & ThisWorkbook.Sheets("definitie").Range("profilename")
    LoadPrfFile sPrfFileName


    Set QualMarkProfile = New clQMProfileSequences           '<<<<<<<<<<<
    QualMarkProfile.CreateClassCollection                          '<<<<<<<<<<<
    
    frmUnitData.Show
End Sub

Display More

in my class module clQMProfileSequences (collection class module) i have following code:

Code

Private c_ProfileSequences As Collection
Private mcTemplate As String
Private p_Name As String


'----------------------------------------------------------------
Private Sub Class_Initialize()
    Set c_ProfileSequences = New Collection
End Sub
'----------------------------------------------------------------
Public Function Add(ByRef mPrfSeq As clQMProfileSequence)
    c_ProfileSequences.Add mPrfSeq, mPrfSeq.Seq_Number_String
End Function


'-----------------------------------------------------------------
Sub CreateClassCollection()
'we fill the Class clQMProfileSequence with  the profile Objects.
    Dim lCntr As Long
    Dim lLastRow As Long
    Dim lRowOffset As Long
    Const cSeqRowOffset As Integer = 28
    Dim ThisSeq As clQMProfileSequence
    
    Dim wsPrfData As Worksheet
    
    Set QualMarkProfile = New clQMProfileSequences
    Set wsPrfData = ThisWorkbook.Sheets("Profile Data")
    With wsPrfData                                          'ThisWorkbook.Worksheets("Profile Data")
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For lCntr = 1 To lLastRow Step cSeqRowOffset
            Set ThisSeq = New clQMProfileSequence
            ThisSeq.Seq_Number_String = .Cells(lCntr, "A").Value
            ThisSeq.Seq_Type_String = .Cells(lCntr + 1, "A").Value
            ThisSeq.Dwell_Time_String = .Cells(lCntr + 5, "A").Value
            ThisSeq.Temp_In_String = .Cells(lCntr + 7, "A").Value
            ThisSeq.End_Temp_String = .Cells(lCntr + 8, "A").Value
            ThisSeq.Temp_Trans_Dur_String = .Cells(lCntr + 10, "A").Value
            ThisSeq.Start_Vib_String = .Cells(lCntr + 11, "A").Value
            ThisSeq.End_Vib_String = .Cells(lCntr + 12, "A").Value
            ThisSeq.Vib_Trans_Dur_String = .Cells(lCntr + 14, "A").Value
            ThisSeq.SSR_Value_String = .Cells(lCntr + 22, "A").Value
            ThisSeq.SSR_Index_String = .Cells(lCntr + 25, "A").Value
            ThisSeq.Last_SSR_String = .Cells(lCntr + 27, "A").Value
            QualMarkSequences.Add ThisSeq                                       '<< Compile Error: Variable not defined
        Next lCntr
    End With
' DON'T SET QualMarkSequences = Nothing, or we lose all Objects in our Class Module!
'do this only at the end when closing the app.
'like :
'    Set QualMarkSequences = Nothing
End Sub




'more code follows

Display More

The problem i have is at the end where i Add the data to the QualMarkSequences.
gives me following error message: Compile Error: Variable not defined

Cause i'm new with Classes, i don't know what i'm doing wrong.

the idea behind it is that i can use the properties and functions like:
SequenceCount = QualMarkProfile.Count
ProfileTime = QualMarkProfile.ProfileTime
...

Anyone who can help me here?

Best regards,
Ludo

Posts by Ludo_Soete

Remove Duplicates from range of cells in excel vba

Remove Duplicates from range of cells in excel vba

Remove Duplicates from range of cells in excel vba

Run macro in Word 2010 from Webbrowser button click

Selected item in listbox not highlighting

Selected item in listbox not highlighting

Can't select Listbox selection

Can't select Listbox selection

Can't select Listbox selection

Can't select Listbox selection

Autozise textbox height for multirow input

Autozise textbox height for multirow input

Autozise textbox height for multirow input

Userform color to RGB values

Userform color to RGB values

Write to .ini file fails - cause?

Write to .ini file fails - cause?

Write to .ini file fails - cause?

Problem with Class module

Problem with Class module