im using console. ive written code its for my exam and im not very good at it but ive tried and no matter what i do i cant get the program to stop crashing. it keeps crashing at code 0 and im really frustrated please help me ive attached the code below
Module Module1
Sub Main()
Dim discount As Integer = 0
Dim freetickets As Integer = 0
Dim estimatedcost As Integer = 0
Dim totalstudents As Integer = 0
Dim coachcost As Integer = 550
Dim entryticket As Integer = 30
Dim name(45) As String
Dim paidstatus(45) As Boolean
Dim studentspaid As Integer = 0
Dim totalcost As Integer = 0
Dim collectedcost As Integer = 0
Dim finalcost As Integer = 0
Console.WriteLine("Enter Student Name")
name(45) = Console.ReadLine()
Console.WriteLine("has the student paid? (true/false)")
paidstatus(45) = Console.ReadLine()
If paidstatus(45) = True Then
studentspaid = studentspaid + 1
totalstudents = totalstudents + 1
ElseIf paidstatus(45) = False Then
totalstudents = totalstudents + 1
End If
totalcost = (totalstudents * 30) + (550 / totalstudents)
If totalstudents = 45 Then
If studentspaid = 10 Then
freetickets = freetickets + 1
End If
If studentspaid = 20 Then
freetickets = freetickets + 1
End If
If studentspaid = 30 Then
freetickets = freetickets + 1
End If
If studentspaid = 40 Then
freetickets = freetickets + 1
End If
collectedcost = (studentspaid * 30) + (550 / studentspaid)
discount = (freetickets * 30) - (550 / studentspaid)
finalcost = totalcost - collectedcost - discount
If finalcost > 0 Then
Console.WriteLine("loss of")
Console.WriteLine(-finalcost)
End If
If finalcost = 0 Then
Console.WriteLine("broken even")
End If
If finalcost < 0 Then
Console.WriteLine("profit of")
Console.WriteLine(finalcost)
End If
End If
End Sub
End Module
here is a script which convert string into hex code:
strString = "test"
strHex =""
For i=1 To Len(strString)
strHex = strHex & " " & Hex(Asc(Mid(strString,i,1)))
Next
strHex = Right(strHex,Len(strHex)-1)
WScript.Echo strHex
I want to do a reverse action which converts hex into string, is this possible using vbscript?
VBScript uses "&H" to mark numbers as hexadecimals. So
>> WScript.Echo Chr("&H" & "41")
>>
A
>>
demonstrates the strategy in principle. Demo code:
Option Explicit
Function s2a(s)
ReDim a(Len(s) - 1)
Dim i
For i = 0 To UBound(a)
a(i) = Mid(s, i + 1, 1)
Next
s2a = a
End Function
Function s2h(s)
Dim a : a = s2a(s)
Dim i
For i = 0 To UBound(a)
a(i) = Right(00 & Hex(Asc(a(i))), 2)
Next
s2h = Join(a)
End Function
Function h2s(h)
Dim a : a = Split(h)
Dim i
For i = 0 To UBound(a)
a(i) = Chr("&H" & a(i))
Next
h2s = Join(a, "")
End Function
Dim s : s = "test"
WScript.Echo 0, s
WScript.Echo 1, s2h(s)
WScript.Echo 2, h2s(s2h(s))
output:
0 test
1 74 65 73 74
2 test
Update wrt comment/unicode:
Use AscW/ChrW (VB ref) to deal with UTF 16.
Option Explicit
Function s2a(s)
ReDim a(Len(s) - 1)
Dim i
For i = 0 To UBound(a)
a(i) = Mid(s, i + 1, 1)
Next
s2a = a
End Function
Function s2h(s)
Dim a : a = s2a(s)
Dim i
For i = 0 To UBound(a)
a(i) = Right("0000" & Hex(AscW(a(i))), 4)
Next
s2h = Join(a)
End Function
Function h2s(h)
Dim a : a = Split(h)
Dim i
For i = 0 To UBound(a)
a(i) = ChrW("&H" & a(i))
Next
h2s = Join(a, "")
End Function
Dim s : s = "abcä" & ChrW("&H" & "d98a")
WScript.Echo 0, s
WScript.Echo 1, s2h(s)
WScript.Echo 2, h2s(s2h(s))
This code does not work I want to create a control array on my Form_Load in VB6 because I have to make 225 of them for a scrabble board and they have to be precise. My code is:
Private lblblocks(1 To 225) As Label
Private Sub Form_Load()
Dim i As Integer, j As Integer
For i = 1 To 15
For j = 1 To 15
Dim arrnum As Integer
arrnum = (i - 1) * 15 + j
Load lblblocks(arrnum)
With lblblocks(arrnum)
.Width = 1000
.Height = 1000
.Top = (i - 1) * 1000
.Left = (j - 1) * 1000
.Visible = True
.BackColor = Int(Rnd(1) * 255) + &H100 * Int(Rnd(1) * 255) + &H10000 * Int(Rnd(1) * 255)
End With
Next j
Next i
End Sub
I used the backcolor to see all my label boxes. This code does not work. I get an error "Object variable or With block variable not set". Any help? I don't know what is wrong. I would like to keep the label boxes in a control array I know how to do it without making it a control array.
Cody Gray had it correct in his comment. I don't believe you can create a control array on the fly only in code in VB6. You have to place one instance of the control on the form and give it an Index property value of zero. This creates a control array with only one element, at index zero. You can then modify your code to produce the desired result, like so:
Private Sub Form_Load()
Dim i As Integer
Dim j As Integer
For i = 0 To 14
For j = 0 To 14
Dim tileIdx As Integer
tileIdx = i * 15 + j
'If the tile index is zero, we already have that control,
'so there's no need to load new instance. Otherwise, use the
'Load method to create a new control in the array with the
'specified index.
If tileIdx > 0 Then
Load lblTile(tileIdx)
End If
With lblTile(tileIdx)
.Width = 1000
.Height = 1000
.Top = i * 1000
.Left = j * 1000
.Visible = True
.BackColor = Int(Rnd(1) * 255) + &H100 * Int(Rnd(1) * 255) + &H10000 * Int(Rnd(1) * 255)
End With
Next
Next
End Sub
As noted in the comment, you don't need to load another instance of the control at array index zero because you did that at design time. I also iterated my array starting from zero for slightly easier calculation of the indices.
we can add from scratch
Private Sub Command3_Click()
Dim rownum As Integer, ColNum As Integer
'Dim lblblocks(1 To 225) As Label
Dim lblblocks() As Label
Dim wwidth As Integer, hheight As Integer
wwidth = 400: hheight = 200
Dim i As Integer, j As Integer
rownum = 20: ColNum = 25
ReDim lblblocks(1 To rownum * ColNum)
For i = 1 To rownum
For j = 1 To ColNum
Dim arrnum As Integer
arrnum = (i - 1) * ColNum + j
Set lblblocks(arrnum) = Me.Controls.Add("VB.Label", "LB" & arrnum)
With lblblocks(arrnum)
'Set Bb(i) = formname.Controls.Add("VB.CommandButton", "Bb" & i)
.Width = wwidth
.Height = hheight
'.Top = (i - 1) * 100
'.Left = (j - 1) * 400
.Top = (i) * hheight
.Left = (j) * wwidth
.Caption = arrnum
.Visible = True
.BackColor = Int(Rnd(1) * 255) + &H100 * Int(Rnd(1) * 255) + &H10000 * Int(Rnd(1) * 255)
End With
Next j
Next i
End Sub
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 have an application in which i'm drawing a line/square on a picturebox. I also need the user to click on a particular point on the picturebox(after drawing the square/line) so as to get the location of the second point. But the mouse down event does not work for the second click. My code is as shown:
Dim m_Drawing As Boolean
'm_Drawing = False
Dim m_Startx As Single
Dim m_Starty As Single
Dim m_endx As Single
Dim m_endy As Single
Dim square_click As Boolean
'square_click = False
Dim line_click As Boolean
'line_click = False
Dim bclick As Boolean
'blick = True
Dim startx As Single
Dim starty As Single
Dim endx As Single
Dim endy As Single
Dim laserx_mm As Single
Dim lasery_mm As Single
Dim rectx_mm As Single
Dim recty_mm As Single
Dim xpos As Single
Dim ypos As Single
Dim uxpos As Single
Dim uypos As Single
Dim dist As Single
Dim dist1 As Single
Private Sub Command1_Click()
square_click = True
End Sub
Private Sub Command2_Click()
line_click = True
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim diffx As Single
Dim diffy As Single
Picture1.Cls
If m_Startx = 0 And m_Starty = 0 Then
m_Startx = X
m_Starty = Y
'End If
startx = X
starty = Y
rectx_mm = X
recty_mm = Y
'move to start position
ElseIf m_Startx <> 0 And m_Starty <> 0 Then
laserx_mm = X
lasery_mm = Y
diffx = rectx_mm - laserx_mm
diffy = recty_mm - lasery_mm
dist = xpos + (diffx / 4.74 / 1000)
dist1 = ypos - (diffy / 4.68 / 1000)
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
endx = X
endy = Y
m_endx = X
m_endy = Y
If square_click = True Then
Picture1.Line (m_Startx, m_Starty)-(endx, endy), vbWhite, B
ElseIf line_click = True Then
Picture1.Line (m_Startx, m_Starty)-(endx, endy), vbWhite
End If
End Sub
The Code: ElseIf m_Startx <> 0 And m_Starty <> 0
does not get executed unless and until i put a breakpoint there. I'm not sure why this is happening. Please help me out! Hope i was clear enough! Thanks.
I threw a Debug.Print "Here I am" call inside your ElseIf m_Startx <> 0 And m_Starty <> 0...Works like a charm on the 2nd click. Perhaps you may want to go with a darker color or a thicker line? The white line is fairly hard to see.