I am creating a program that prints the element of array one at a time (from top left to bottom right) using the timer control, however, it's not printing the elements one at a time, it prints all of them at the same time. I need help, below is a sample screenshot and my code so far.
Public Class SymbolDrawFRM
Private symbol(10, 10) As String
Sub Drawing()
Dim s As String = ""
For i = 1 To rowNUD.Value
For j = 1 To columnNUD.Value
s = s & symbol(i, j) & # & " "
Next
s = s & vbCrLf
Next
outputTBX.Text = s
End Sub
Private Sub startStopBTN_Click(sender As Object, e As EventArgs) Handles startStopBTN.Click
Timer.Start()
End Sub
Private Sub Timer_Tick(sender As Object, e As EventArgs) Handles Timer.Tick
Drawing()
End Sub
End Class
Ignoring the Array, and only using the NumericUpDown controls:
Private Sub startStop_Click(sender As Object, e As EventArgs) Handles startStop.Click
Timer1.Interval = 500
Timer1.Enabled = Not Timer1.Enabled
End Sub
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
Static x As Integer
Static y As Integer
If x = 0 And y = 0 Then
outputTBX.Clear()
End If
outputTBX.AppendText("# ")
x = x + 1
If x = columnNUD.Value Then
x = 0
outputTBX.AppendText(vbCrLf)
y = y + 1
If y = rowNUD.Value Then
x = 0
y = 0
Timer1.Stop()
MessageBox.Show("Done!")
End If
End If
End Sub
Trying to make the game "21" in visual basic 6, i have everything done but MsgBox is not displaying when its Bust, or Blackjack. Any ideas?
Private Sub cmdCheckScore_Click()
lblPC1.Visible = True
lblPC2.Visible = True
lblPC3.Visible = True
End Sub
Private Sub cmdDrawCard_Click()
If lblDraw1.Caption = "" Then 'Draws 3 random numbers with 3 button clicks
intDraw1 = Int(Rnd * 10 + 1)
lblDraw1.Caption = intDraw1
ElseIf lblDraw2.Caption = "" Then
intDraw2 = Int(Rnd * 10 + 1)
lblDraw2.Caption = intDraw2
ElseIf lblDraw3.Caption = "" Then
intDraw3 = Int(Rnd * 10 + 1)
lblDraw3.Caption = intDraw3
End If
intPlayerScore = intPlayer1 + intPlayer2 + intDraw1 + intDraw2 + intDraw3
intComputerScore = intPC1 + intPC2 + intPC3
If intPlayerScore > 21 Then
MsgBox "Bust!"
ElseIf intPlayerScore = 21 Then
MsgBox "Blackjack!"
End If
End Sub
Private Sub Form_Load()
Randomize
Dim intPlayer1 As Integer
Dim intPlayer2 As Integer
Dim intPlayer3 As Integer
Dim intPC1 As Integer
Dim intPC2 As Integer
Dim intPC3 As Integer
Dim intDraw1 As Integer
Dim intDraw2 As Integer
Dim intDraw3 As Integer
Dim PlayerScore As Integer
Dim ComputerScore As Integer
intDraw1 = 0
intDraw2 = 0
intDraw3 = 0
intPlayer1 = Int(Rnd * 10 + 1)
intPlayer2 = Int(Rnd * 10 + 1)
lblPlayer1.Caption = intPlayer1
lblPlayer2.Caption = intPlayer2
intPC1 = Int(Rnd * 10 + 1)
intPC2 = Int(Rnd * 10 + 1)
intPC3 = Int(Rnd * 10 + 1)
lblPC1.Caption = intPC1
lblPC2.Caption = intPC2
lblPC3.Caption = intPC3
End Sub
I've been trying to figure this out for 2 hours, and still no solution.
I believe your variables are getting created out of scope, and therefore when the click code runs, they're all variants.
Move your declares out of Form_Load to above cmdCheckScore
Dim intPlayer1 As Integer 'at the top of your FORM
Dim intPlayer2 As Integer
Dim intPlayer3 As Integer
Dim intPC1 As Integer
Dim intPC2 As Integer
Dim intPC3 As Integer
Dim intDraw1 As Integer
Dim intDraw2 As Integer
Dim intDraw3 As Integer
Dim PlayerScore As Integer
Dim ComputerScore As Integer 'at the top of your FORM
Private Sub cmdCheckScore_Click()
Next, click off to the left and set a breakpoint on this line to verify the values are getting there!
intPlayerScore = intPlayer1 + intPlayer2 + intDraw1 + intDraw2 + intDraw3
Current high school student learning vb6 and having this major problem when trying to set the left and top values of these image boxes. I keep getting the error:
Object Variable or With Block Variable Not Set
and debug seems to lead it to the left and top value variables.
Option Explicit
Dim GapY As Integer
Dim GapX As Integer
Dim x As Integer
Dim y As Integer
Dim Tile() As Image
Dim NumOfTiles
Dim h, i As Integer 'Counter
Private Sub cmdRender_Click()
x = 480
y = 480
GapX = Val(InputBox("Enter How Many tile you want horizontally:"))
GapY = Val(InputBox("Enter How Many tile you want vertically"))
NumOfTiles = (GapY * GapX)
ReDim Tile(NumOfTiles)
For i = 1 To GapY
For h = 1 To GapX
Tile(h).Height = 615
Tile(h).Width = 615
Tile(h).Left = x
Tile(h).Top = y
'Tile(h).Stretch = True
x = x + 600
Next
y = y + 600
x = 480
Next
End Sub
You have not assigned any image to your tile array, i.e. you have an array with NumOfTiles empty positions.
I don't know where you are getting your images from. You might create images with new Image or read images from files or take them from image boxes on a form etc.
Probably you want to work with PictureBox controls. if you have such controls on a form, you would have to type the array as such
Dim Tile() As PictureBox
ReDim Tile(NumOfTiles) As PictureBox
And then assign them from your form (assuming that you have placed some on a form):
Set Tile(1) = pictureBox1
Set Tile(2) = pictureBox2
...
or in a loop
For i = 1 To NumOfTiles
Set Tile(i) = Me("pictureBox" & i)
Tile(i).Left = ...
Next
or create them on the form with something like this (I did not try it out)
Set Tile(i) = Me.Controls.Add("VB.PictureBox", "pictureBox" & i)
I have been asked to ask this question again and in a little different context. This is the previous post:
Filtering in VBA after finding combinations
I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.
The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for < 10 boxes)
This is my input:
3 A B C D E ...
7.7 3 1 1 1 2 ...
5.5 2 1 2 3 3 ...
This is the code:
Function stackBox()
Dim ws As Worksheet
Dim width As Long
Dim height As Long
Dim numOfBox As Long
Dim optionsA() As Variant
Dim results() As Variant
Dim str As String
Dim outputArray As Variant
Dim i As Long, j As Long
Dim currentSymbol As String
'------------------------------------new part----------------------------------------------
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight As Double
'------------------------------------new part----------------------------------------------
Set ws = Worksheets("Sheet1")
With ws
'clear last time's output
height = .Cells(.Rows.Count, 1).End(xlUp).row
If height > 3 Then
.Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
End If
numOfBox = .Cells(1, 1).Value
width = .Cells(1, .Columns.Count).End(xlToLeft).Column
If width < 2 Then
MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
Exit Function
End If
'------------------------------------new part----------------------------------------------
maxHeight = .Cells(2, 1).Value
maxWeight = .Cells(3, 1).Value
ReDim heightarray(1 To 1, 1 To width - 1)
ReDim weightarray(1 To 1, 1 To width - 1)
heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
'------------------------------------new part----------------------------------------------
ReDim optionsA(0 To width - 2)
For i = 0 To width - 2
optionsA(i) = .Cells(1, i + 2).Value
Next i
GenerateCombinations optionsA, results, numOfBox
' copy the result to sheet only once
ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
Count = 0
For i = LBound(results, 1) To UBound(results, 1)
If Not IsEmpty(results(i)) Then
'rowNum = rowNum + 1
str = ""
totalHeight = 0#
totalWeight = 0#
For j = LBound(results(i), 1) To UBound(results(i), 1)
currentSymbol = results(i)(j)
str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C
'look up box's height and weight , increment the totalHeight/totalWeight
updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight
Next j
If totalHeight < maxHeight And totalWeight < maxWeight Then
Count = Count + 1
outputArray(Count, 1) = str
End If
'.Cells(rowNum, 1).Value = str
End If
Next i
.Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
End With
End Function
Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
If targetSymbol = symbolArray(i) Then
index = i
Exit For
End If
Next i
If index <> -1 Then
totalHeight = totalHeight + heightarray(1, index + 1)
totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant, ByVal numOfBox As Long)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
If InxResultCrnt = 0 Then
Debug.Print "testing"
End If
'additional logic here
If InxResultCrnt >= numOfBox Then
Result(InxResult) = Empty
Else
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
End If
Next
End Sub
Here's a version that does all the heavy lifting in variant arrays
(Combinations logic based on this answer for This Answer by Joubarc)
This runs on a sample dataset of 100 boxes with > 40,000 returned, and in < 1 second
Notes:
Execution time rises quickly if the Max number of boxes increases (eg 4 from 100: approx 13s)
If the number of returned results exceeds 65535, the code to tranpose the array into the sheet fails (last line of the sub) If you need to handle this may results, you will need to change the way results are returned to the sheet
Sub Demo()
Dim rNames As Range
Dim rHeights As Range
Dim rWeights As Range
Dim aNames As Variant
Dim aHeights As Variant
Dim aWeights As Variant
Dim MaxNum As Long
Dim MaxHeight As Double
Dim MaxWeight As Double
' *** replace these six line with your data ranges
Set rNames = Range([F5], [F5].End(xlToRight))
Set rHeights = rNames.Offset(1, 0)
Set rWeights = rNames.Offset(2, 0)
MaxNum = [C5]
MaxHeight = [C6]
MaxWeight = [C7]
aNames = rNames
aHeights = rHeights
aWeights = rWeights
Dim Result() As Variant
Dim n As Long, m As Long
Dim i As Long, j As Long
Dim iRes As Long
Dim res As String
Dim TestCombin() As Long
Dim TestWeight As Double
Dim TestHeight As Double
Dim idx() As Long
' Number of boxes
ReDim TestCombin(0 To MaxNum - 1)
n = UBound(aNames, 2) - LBound(aNames, 2) + 1
' estimate size of result array = number of possible combinations
For m = 1 To MaxNum
i = i + Application.WorksheetFunction.Combin(n, m)
Next
ReDim Result(1 To 3, 1 To i)
' allow for from 1 to MaxNum of boxes
iRes = 1
For m = 1 To MaxNum
ReDim idx(0 To m - 1)
For i = 0 To m - 1
idx(i) = i
Next i
Do
'Test current combination
res = ""
TestWeight = 0#
TestHeight = 0#
For j = 0 To m - 1
'Debug.Print aNames(1, idx(j) + 1);
res = res & aNames(1, idx(j) + 1)
TestWeight = TestWeight + aWeights(1, idx(j) + 1)
TestHeight = TestHeight + aHeights(1, idx(j) + 1)
Next j
'Debug.Print
If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
Result(1, iRes) = res
' optional, include actual Height and Weight in result
Result(2, iRes) = TestHeight
Result(3, iRes) = TestWeight
iRes = iRes + 1
End If
' Locate last non-max index
i = m - 1
While (idx(i) = n - m + i)
i = i - 1
If i < 0 Then
'All indexes have reached their max, so we're done
Exit Do
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i To m - 1
idx(j) = idx(i) + j - i
Next j
Loop
Next
' Return Result to sheet
Dim rng As Range
ReDim Preserve Result(1 To 3, 1 To iRes)
' *** Adjust returnm range to suit
Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
rng = Application.Transpose(Result)
End Sub
I tested the code in this webpage that is for moving a picturebox in runtime: http://www.davidsuarez.es/2007/11/mover-y-soltar-controles-con-drag-drop-visual-basic/
I created a Form with two pictureboxex: Picture1 and Picture2 (the page is in Spanish, so I copy the modified code here):
Dim DY As Single
Dim DX As Single
Dim Flag_MouseMove As Boolean
Private Sub CancelarDrag(Source As Control)
Source.Visible = True
Source.Drag vbCancel
End Sub
Private Sub FinalizarDrag(Source As Control, Button As Integer)
If Button = vbLeftButton Then
Source.Visible = True
Source.ZOrder
Source.Drag vbEndDrag
End If
End Sub
Private Sub IniciarDrag(Source As Control, Button As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
DX = X
DY = Y
Source.Drag vbBeginDrag
Source.Visible = False
Source.Drag
End If
End Sub
Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
Dim ejeY, ejeX As Single
ejeX = X - 60
ejeY = Y - 60
ejeX = ejeX - DX
ejeY = ejeY - DY
Source.Visible = True
Source.Move ejeX, ejeY
Source.Drag vbEndDrag
Source.ZOrder
End Sub
Private Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)
CancelarDrag Picture1
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IniciarDrag Picture1, Button, X, Y
Flag_MouseMove = True
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
FinalizarDrag Picture1, Button
Flag_MouseMove = False
End Sub
Private Sub Picture2_DragDrop(Source As Control, X As Single, Y As Single)
CancelarDrag Picture2
End Sub
Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IniciarDrag Picture2, Button, X, Y
Flag_MouseMove = True
End Sub
Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
FinalizarDrag Picture2, Button
Flag_MouseMove = False
End Sub
The code works nicely, except if the cursor is inside the area of the other picturebox and I drop my moving picturebox there. The moving picturebox disappears and never comes back until I reload the form. How can I avoid this "picturebox disappearing"?.
I got it! The problem is in the "IniciarDrag" function. The Source control must be always visible, that solves any problems (like trying to place the control outside the form!):
Source.Visible = True