Applying a command on many objects ? VB6 - vb6

thanks for reading.
I'm writing a program to create a list consisting of 8 cols. so there are8 listboxes and a textbox under each one.
I want to check each textbox one by one if anyone is empty or not. ...and dunno how to do that!
I need your help!
thanks

instead of using 8 listboxes you might consider using a flexgrid control
but using 8 listboxes and 8 textboxes, you can create them as an array and check them as follows :
'1 form with with
' 1 listbox : name=List1 index=0
' 1 textbox : name=Text1 index=0
' 1 commandbutton : name=Command1
Option Explicit
Private Sub Command1_Click()
If IsEmpty Then
MsgBox "Textboxes are all empty", vbInformation, "IsEmpty"
Else
MsgBox "At least 1 Textbox is not empty", vbInformation, "IsEmpty"
End If
End Sub
Private Sub Form_Load()
Dim intIndex As Integer
For intIndex = 1 To 7
Load List1(intIndex)
Load Text1(intIndex)
List1(intIndex).Visible = True
Text1(intIndex).Visible = True
Next intIndex
Move 0, 0, 10000, 10000
End Sub
Private Function IsEmpty() As Boolean
Dim intIndex As Integer
Dim blnEmpty As Boolean
blnEmpty = True
For intIndex = 0 To Text1.Count - 1
If Len(Text1(intIndex).Text) > 0 Then
blnEmpty = False
Exit For
End If
Next intIndex
IsEmpty = blnEmpty
End Function
Private Sub Form_Resize()
Dim intIndex As Integer
Dim sngWidth As Single
Dim sngListWidth As Single, sngListHeight As Single
Dim sngTextHeight As Single
Dim sngCmdHeight As Single
sngWidth = ScaleWidth
sngListWidth = sngWidth / List1.Count
sngTextHeight = 315
sngCmdHeight = 315
sngListHeight = ScaleHeight - sngTextHeight - sngCmdHeight
For intIndex = 0 To List1.Count - 1
List1(intIndex).Move intIndex * sngListWidth, 0, sngListWidth, sngListHeight
Text1(intIndex).Move intIndex * sngListWidth, sngListHeight, sngListWidth, sngTextHeight
Next intIndex
Command1.Move 0, sngListHeight + sngTextHeight, sngWidth, sngCmdHeight
End Sub

Related

Using variable as a label control name

In VB 6 How can I refer to control label using a variable instead of a fixed name such as LUH01 (as below) which does not allow a Loop.
Frm_Dispo_Prof_Grille.LUH01.BackColor = &HFF00&
You can refer to it via the Controls Collection:
Frm_Dispo_Prof_Grille.Controls("LUH01").BackColor = &HFF00&
Be careful, however. If you need to refer to a property/method that is not one of the standard/built-in ones, you'll have to cast the control to a type:
Dim lbl as Label
Set lbl = Frm_Dispo_Prof_Grille.Controls("LUH01")
lbl.BackColor = &HFF00
I think you want to create a control array
You can do that by creating 1 control, and set its Index property to 0 (instead of empty)
You can then Load new controls and use them all in a loop
For example to load some command buttons and position them in a loop:
'1 form with :
' 1 command button: name=Command1 index=0
'Number of command buttons to use in the loop
Private Const NRBUTTONS As Integer = 5
Option Explicit
Private Sub Form_Load()
Dim intIndex As Integer
'change the caption of the default button
Command1(0).Caption = "Button 0"
For intIndex = 1 To NRBUTTONS - 1
'load an extra command button
Load Command1(intIndex)
'change the caption of the newly loaded button
Command1(intIndex).Caption = "Button " & CStr(intIndex)
'newly load command buttons are invisible by deafult
'make the new command button visible
Command1(intIndex).Visible = True
Next intIndex
End Sub
Private Sub Form_Resize()
'arrange all loaded command buttons via a loop
Dim intIndex As Integer
Dim sngWidth As Single
Dim sngHeight As Single
sngWidth = ScaleWidth
sngHeight = ScaleHeight / NRBUTTONS
For intIndex = 0 To NRBUTTONS - 1
Command1(intIndex).Move 0, intIndex * sngHeight, sngWidth, sngHeight
Next intIndex
End Sub

Sending data to device via MS Comm VB6

I need to send a file to some electronic device and execute it.
I couldn't find any information online regarding MS Comms and I didn't find Documentation on the Microsoft (https://msdn.microsoft.com/en-us/library/aa231237(v=vs.60).aspx) any useful :
' Send Byte array data
MSComm1.Output = Out
Would be great if you guys could give me some pointers and help me to solve my problem. The problem that I am experiencing is an infinite loop at Loop Until MSComm1.OutBufferCount = 0, when I return "MSComm1.OutBufferCount" between Do and Loop "MSComm1.OutBufferCount" is 0 and files dont seem to be sent over to the device.
Closest function I got to at the present moment is below:
Function SendFile(tmp$)
Dim temp$
Dim hsend, bsize, LF&
' Open file
Open tmp$ For Binary Access Read As #2
' Check size on Mscomm1 OutBuffer
bsize = MSComm1.OutBufferSize
' Check file length
LF& = LOF(2)
' This code makes tiny pieces of data (Buffer sized)
' And send's it
Do Until EOF(2)
If LF& - Loc(2) <= bsize Then
bsize = LF& - Loc(2) + 1
End If
' Make room for some data
temp$ = Space$(bsize)
' Put the data piece in the Temp$ string
Get #2, , temp$
MSComm1.Output = temp$
Do
' Wait until the buffer is empty
Loop Until MSComm1.OutBufferCount = 0
Loop
' close file
Close #2
End Function
Have a look at the RThreshold and SThreshold properties
Below is a simple example project :
'1 form with :
' 1 label control : name=Label1
' 1 textbox control : name=Text1
' 1 command button : name=Command1
Option Explicit
Private Sub Command1_Click()
'send command
MSComm1.Output = Text1.Text & vbCr
End Sub
Private Sub Form_Load()
'config mscomm control and open connection
With MSComm1
.Settings = "9600,N,8,1"
.RThreshold = 1
.SThreshold = 0
.CommPort = 1
.PortOpen = True
End With 'MSComm1
End Sub
Private Sub Form_Resize()
'position controls
Dim sngWidth As Single, sngHeight As Single
Dim sngCmdWidth As Single, sngCmdHeight As Single
Dim sngTxtWidth As Single
Dim sngLblHeight As Single
sngWidth = ScaleWidth
sngHeight = ScaleHeight
sngCmdWidth = 1215
sngCmdHeight = 495
sngLblHeight = sngHeight - sngCmdHeight
sngTxtWidth = sngWidth - sngCmdWidth
Label1.Move 0, 0, sngWidth, sngLblHeight
Text1.Move 0, sngLblHeight, sngTxtWidth, sngCmdHeight
Command1.Move sngTxtWidth, sngLblHeight, sngCmdWidth, sngCmdHeight
End Sub
Private Sub MSComm1_OnComm()
'process received data
Dim strInput As String
Select Case MSComm1.CommEvent
Case comEvReceive
strInput = MSComm1.Input
Label1.Caption = Label1.Caption & strInput
End Select
End Sub
In Command1_Click I add a carriage return to the command from Text1 as most devices require the command to be finished by that
In MSComm1_OnComm I just print the received data to the label, but you might want to add the received data to a global variable, and then process the contents of that variable, as all data might not be received at once

unloading items from popup menu error

i have am getting this error
"Unable to unload within this context"
when ever i try to unload a menu item from the popupmenu like his
For i = mnuTCategory.Count - 1 To 1 Step -1
Unload mnuTCategory(i)
Next
Is there any way to do this without this error>?
Thanks
In order to be able to remove controls from a Form, when triggered by a ComboBox, you will need to execute the deletion operation through a Timer.
So, when the ComboBox event is to be triggered, start (enable) a Timer that when triggered, calls the subroutine that you wanted to call in the first place.
This is how the code would look like:
Private Sub MyCombo_Change()
MyTimer.Enabled = False
MyTimer.Enabled = True
End Sub
Private Sub MyTimer_Timer()
MyTimer.Enabled = False
DeleteMenuItems
End Sub
Private Sub DeleteMenuItems()
Dim i As Intener
For i = mnuTCategory.Count - 1 To 1 Step -1
Unload mnuTCategory(i)
Next
End Sub
my test project below works without errors for me, does it work for you ?
'1 form with :
' 1 command button : name=Command1
' 1 main menu item : name=mnuMain
' 1 sub menu item : name=mnuSub index=0
Option Explicit
Private Sub Command1_Click()
Dim intIndex As Integer
For intIndex = mnuSub.Count - 1 To 1 Step -1
Unload mnuSub(intIndex)
Next intIndex
End Sub
Private Sub Form_Load()
Dim intIndex As Integer
For intIndex = 1 To 3
Load mnuSub(intIndex)
mnuSub(intIndex).Caption = "Sub" & CStr(intIndex)
Next intIndex
End Sub
Edit
funny!
the testproject below gives the same error : it is indeed caused by calling the unload from an combobox ..
'1 form with :
' 1 combobox : name=Combo1
' 1 main menu item : name=mnuMain
' 1 sub menu item : name=mnuSub index=0
Option Explicit
Private Sub Combo1_Click()
Dim intIndex As Integer
With Combo1
Select Case .ListIndex
Case 0 'add
For intIndex = 1 To 3
Load mnuSub(intIndex)
mnuSub(intIndex).Caption = "Sub" & CStr(intIndex)
Next intIndex
Case 1 'del
For intIndex = mnuSub.Count - 1 To 1 Step -1
Unload mnuSub(intIndex)
Next intIndex
End Select
End With 'Combo1
End Sub
Private Sub Form_Load()
With Combo1
.AddItem "add"
.AddItem "del"
End With 'Combo1
End Sub
this intrigues me but i can't find a cleaner solution than using another control, this control can be an control which you already have on your form, or a dummy control just for this purpose. you can then use the lostfocus event of the combobox
see the testproject below :
'1 form with :
' 1 combobox : name=Combo1
' 1 textbox : name=Text1
' 1 main menu item : name=mnuMain
' 1 sub menu item : name=mnuSub index=0
Option Explicit
Private Sub Combo1_Click()
Dim intIndex As Integer
With Combo1
Select Case .ListIndex
Case 0 'add
For intIndex = 1 To 3
Load mnuSub(intIndex)
mnuSub(intIndex).Caption = "Sub" & CStr(intIndex)
Next intIndex
Case 1 'del
Text1.SetFocus
End Select
End With 'Combo1
End Sub
Private Sub Combo1_LostFocus()
'use the lostfocus event to unload stuff
Dim intIndex As Integer
For intIndex = mnuSub.Count - 1 To 1 Step -1
Unload mnuSub(intIndex)
Next intIndex
End Sub
Private Sub Form_Load()
With Combo1
.AddItem "add"
.AddItem "del"
End With 'Combo1
End Sub
Private Sub Text1_GotFocus()
Combo1.SetFocus
End Sub

How to give a name to each list item in Visual Basic 6

I am making a music player using the list control. I want to let the user change the name of the song on the list, but i want some property of THAT list item to contain its path.
Please help me in this. Any kind of help will be appreciated. Thanks in advance.
EDIT
Private Sub AddToList(ByVal txtFileName As String)
Dim I As Integer
Dim blnFileAlreadyexists As Boolean
txtFileName = Trim(txtFileName)
If txtFileName <> "" Then
blnFileAlreadyexists = False
For I = 0 To List1.ListCount - 1
If Trim(List1.List(I)) = txtFileName Then
blnFileAlreadyexists = True
End If
Next
If Not blnFileAlreadyexists Then
List1.AddItem (txtFileName)
List1.ItemData (txtFileName)
End If
End If
End Sub
For a listbox, after you add an item set its x.itemdata(x.newindex) to the index of an array (or UDT array) that contains the corresponding data.
For a listview you can similarly use an individual items .Tag or .Key to store an array (or collection) index.
Linking a listbox example;
Option Explicit
Private Type TFileData
OriginalFilePath As String
ListBoxIndex As Integer
MoreBlaBla As String
'//any more members
End Type
Private maFiles() As TFileData
Private Sub Form_Load()
'//initial alloc
ReDim maFiles(0)
AddToList "AAAA"
AddToList "BBBB"
AddToList "AAAA"
AddToList "CCCC"
'//test by looping listbox;
Dim i As Integer
For i = 0 To List1.ListCount - 1
MsgBox List1.List(i) & " - " & maFiles(List1.ItemData(i)).OriginalFilePath
Next
'// a better type centric test;
For i = 0 To UBound(maFiles) - 1
MsgBox maFiles(i).OriginalFilePath & " - List entry: " & List1.List(maFiles(i).ListBoxIndex)
Next
End Sub
Private Sub AddToList(ByVal txtFileName As String)
Dim i As Integer
Dim blnFileAlreadyexists As Boolean
txtFileName = Trim(txtFileName)
If txtFileName <> "" Then
blnFileAlreadyexists = False
For i = 0 To List1.ListCount - 1
If Trim(List1.List(i)) = txtFileName Then
blnFileAlreadyexists = True
End If
Next
If Not blnFileAlreadyexists Then
'//add to list
List1.AddItem (txtFileName)
'//store the original value in the array;
maFiles(UBound(maFiles)).OriginalFilePath = "TEST: " & txtFileName
'//store the index of the array in the list;
List1.ItemData(List1.NewIndex) = UBound(maFiles)
'//or better store in the type
maFiles(UBound(maFiles)).ListBoxIndex = List1.NewIndex
'//increment the array for the next item;
ReDim Preserve maFiles(UBound(maFiles) + 1)
End If
End If
End Sub

How to add events to Controls created at runtime in Excel with VBA

I would like to add a Control and an associated event at runtime in Excel using VBA but I don't know how to add the events.
I tried the code below and the Button is correctly created in my userform but the associated click event that should display the hello message is not working.
Any advice/correction would be welcome.
Dim Butn As CommandButton
Set Butn = UserForm1.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With ThisWorkbook.VBProject.VBComponents("UserForm1.CommandButton1").CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
UserForm1.Show
The code for adding a button at runtime and then to add events is truly as simple as it is difficult to find out. I can say that because I have spent more time on this perplexity and got irritated more than in anything else I ever programmed.
Create a Userform and put in the following code:
Option Explicit
Dim ButArray() As New Class2
Private Sub UserForm_Initialize()
Dim ctlbut As MSForms.CommandButton
Dim butTop As Long, i As Long
'~~> Decide on the .Top for the 1st TextBox
butTop = 30
For i = 1 To 10
Set ctlbut = Me.Controls.Add("Forms.CommandButton.1", "butTest" & i)
'~~> Define the TextBox .Top and the .Left property here
ctlbut.Top = butTop: ctlbut.Left = 50
ctlbut.Caption = Cells(i, 7).Value
'~~> Increment the .Top for the next TextBox
butTop = butTop + 20
ReDim Preserve ButArray(1 To i)
Set ButArray(i).butEvents = ctlbut
Next
End Sub
Now you need to add a Class Module to your code for the project. Please remember it's class module, not Standard Module.
The Object butEvents is the button that was clicked.
Put in the following simple code (in my case the class name is Class2).
Public WithEvents butEvents As MSForms.CommandButton
Private Sub butEvents_click()
MsgBox "Hi Shrey from " & butEvents.Caption
End Sub
That's it. Now run it!
Try this:
Sub AddButtonAndShow()
Dim Butn As CommandButton
Dim Line As Long
Dim objForm As Object
Set objForm = ThisWorkbook.VBProject.VBComponents("UserForm1")
Set Butn = objForm.Designer.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With objForm.CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
VBA.UserForms.Add(objForm.Name).Show
End Sub
This permanently modifies UserForm1 (assuming you save your workbook). If you wanted a temporary userform, then add a new userform instead of setting it to UserForm1. You can then delete the form once you're done with it.
Chip Pearson has some great info about coding the VBE.
DaveShaw, thx for this code man!
I have used it for a togglebutton array (put a 'thumbnail-size' picture called trainer.jpg in the same folder as the excel file for a togglebutton with a picture in it). In the 'click' event the invoker is also available (by the object name as a string)
In the form:
Dim CreateTrainerToggleButtonArray() As New ToggleButtonClass
Private Sub CreateTrainerToggleButton(top As Integer, id As Integer)
Dim pathToPicture As String
pathToPicture = ThisWorkbook.Path & "\trainer.jpg"
Dim idString As String
idString = "TrainerToggleButton" & id
Dim cCont As MSForms.ToggleButton
Set cCont = Me.Controls.Add _
("Forms.ToggleButton.1")
With cCont
.Name = idString
.Width = 20
.Height = 20
.Left = 6
.top = top
.picture = LoadPicture(pathToPicture)
End With
ReDim Preserve CreateTrainerToggleButtonArray(1 To id)
Set CreateTrainerToggleButtonArray(id).ToggleButtonEvents = cCont
CreateTrainerToggleButtonArray(id).ObjectName = idString
End Sub
and a class "ToggleButtonClass"
Public WithEvents ToggleButtonEvents As MSForms.ToggleButton
Public ObjectName As String
Private Sub ToggleButtonEvents_click()
MsgBox "DaveShaw is the man... <3 from your friend: " & ObjectName
End Sub
Now just simple call from UserForm_Initialize
Private Sub UserForm_Initialize()
Dim index As Integer
For index = 1 To 10
Call CreateTrainerToggleButton(100 + (25 * index), index)
Next index
End Sub
This was my solution to add a commandbutton and code without using classes
It adds a reference to allow access to vbide
Adds the button
Then writes a function to handle the click event in the worksheet
Sub AddButton()
Call addref
Set rng = DestSh.Range("B" & x + 3)
'Set btn = DestSh.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
Set myButton = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Left:=rng.Left, Top:=rng.Top, Height:=rng.Height * 3, Width:=rng.Width * 3)
DoEvents
With myButton
'.Placement = XlPlacement.xlFreeFloating
.Object.Caption = "Export"
.Name = "BtnExport"
.Object.PicturePosition = 1
.Object.Font.Size = 14
End With
Stop
myButton.Object.Picture = LoadPicture("F:\Finalised reports\Templates\Macros\evolution48.bmp")
Call CreateButtonEvent
End Sub
Sub addref()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
End Sub
Private Sub CreateButtonEvent()
On Error GoTo errtrap
Dim oXl As Application: Set oXl = Application
oXl.EnableEvents = False
oXl.DisplayAlerts = False
oXl.ScreenUpdating = False
oXl.VBE.MainWindow.Visible = False
Dim oWs As Worksheet
Dim oVBproj As VBIDE.VBProject
Dim oVBcomp As VBIDE.VBComponent
Dim oVBmod As VBIDE.CodeModule '
Dim lLine As Single
Const QUOTE As String = """"
Set oWs = Sheets("Contingency")
Set oVBproj = ThisWorkbook.VBProject
Set oVBcomp = oVBproj.VBComponents(oWs.CodeName)
Set oVBmod = oVBcomp.CodeModule
With oVBmod
lLine = .CreateEventProc("Click", "BtnExport") + 1
.InsertLines lLine, "Call CSVFile"
End With
oXl.EnableEvents = True
oXl.DisplayAlerts = True
Exit Sub
errtrap:
End Sub
An easy way to do it:
1 - Insert a class module and write this code:
Public WithEvents ChkEvents As MSForms.CommandButton
Private Sub ChkEvents_click()
MsgBox ("Click Event")
End Sub
2 - Insert a userform and write this code:
Dim Chk As New Clase1
Private Sub UserForm_Initialize()
Dim NewCheck As MSForms.CommandButton
Set NewCheck = Me.Controls.Add("Forms.CommandButton.1")
NewCheck.Caption = "Prueba"
Set Chk.ChkEvents = NewCheck
End Sub
Now show the form and click the button
I think the code needs to be added to the Userform, not to the button itself.
So something like
With UserForm1.CodeModule
'Insert code here
End With
In place of your With ThisWorkbook

Resources