Can anyone tell me if it's possible to fill a polygon with a gradient in VB6?
The code below will draw a gradient filled rectangle. I modified it slightly from this thread from vbcity.com.
Drop this into a Module:
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Sub gdiDrawGradient( _
ByVal hdc As Long, _
ByRef rct As RECT, _
ByVal lEndColor As Long, _
ByVal lStartColor As Long, _
ByVal bVertical As Boolean)
Dim lStep As Long
Dim lPos As Long, lSize As Long
Dim bRGB(1 To 3) As Integer
Dim bRGBStart(1 To 3) As Integer
Dim dR(1 To 3) As Double
Dim dPos As Double, d As Double
Dim hBr As Long
Dim tR As RECT
LSet tR = rct
If bVertical Then
lSize = (tR.Bottom - tR.Top)
Else
lSize = (tR.Right - tR.Left)
End If
lStep = lSize \ 255
If (lStep < 3) Then
lStep = 3
End If
bRGB(1) = lStartColor And &HFF&
bRGB(2) = (lStartColor And &HFF00&) \ &H100&
bRGB(3) = (lStartColor And &HFF0000) \ &H10000
bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
dR(1) = (lEndColor And &HFF&) - bRGB(1)
dR(2) = ((lEndColor And &HFF00&) \ &H100&) - bRGB(2)
dR(3) = ((lEndColor And &HFF0000) \ &H10000) - bRGB(3)
For lPos = lSize To 0 Step -lStep '
' Draw bar
If bVertical Then
tR.Top = tR.Bottom - lStep
Else
tR.Left = tR.Right - lStep
End If
If tR.Top < rct.Top Then
tR.Top = rct.Top
End If
If tR.Left < rct.Left Then
tR.Left = rct.Left
End If
hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
FillRect hdc, tR, hBr
DeleteObject hBr
' Adjust colour '
dPos = ((lSize - lPos) / lSize)
If bVertical Then
tR.Bottom = tR.Top
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
Else
tR.Right = tR.Left
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
End If
Next lPos
End Sub
To test, add this code to a form:
Private Sub Command1_Click()
Dim r As RECT
r.Left = 10
r.Top = 10
r.Right = 100
r.Bottom = 150
Call gdiDrawGradient(Me.hdc, r, vbRed, vbBlue, True)
End Sub
Here's how to fill any polygon with a gradient, using Windows API calls from VB6.
Here's how to fill a PictureBox with a gradient, pure VB6 with no API calls.
Related
I want to remove and insert spaces after every byte in a hex string.
E.g.: if the hex string is
str = "0F0D3E"
then I want to insert spaces after every byte to obtain
str = "0F 0D 3E"
and also the reverse (remove spaces from the string so the string becomes "0F0D3E" again).
A quick and naïve approach would be:
Option Explicit
Private Sub Form_Load()
Dim sSrc As String
Dim sTgt As String
sSrc = "0F0D3E"
sTgt = SpaceIt(sSrc)
Debug.Print sTgt
sSrc = UnspaceIt(sTgt)
Debug.Print sSrc
End Sub
Private Function SpaceIt(sSrc As String) As String
Dim i As Long
Dim asSrc() As String
ReDim asSrc(0 To Len(sSrc) \ 2 - 1) As String
For i = 0 To Len(sSrc) - 1 Step 2
asSrc(i \ 2) = Mid$(sSrc, i + 1, 2)
Next i
SpaceIt = Join(asSrc, " ")
End Function
Private Function UnspaceIt(sSrc As String) As String
UnspaceIt = Replace(sSrc, " ", "")
End Function
You can harness the power of the Mid$ statement and the Mid$ function and a little arithmetic to write a function to do this pretty flexibly and efficiently:
Private Function Spacify( _
ByVal Text As String, _
ByVal StrideIn As Long, _
ByVal StrideOut As Long, _
Optional ByVal RTrim As Boolean) As String
Dim OutLen As Long
Dim CopyLen As Long
Dim OutPos As Long
Dim InPos As Long
If StrideIn <= StrideOut Then
OutLen = (Len(Text) \ StrideIn) * StrideOut
If RTrim Then OutLen = OutLen - (StrideOut - StrideIn)
CopyLen = StrideIn
Else
OutLen = ((Len(Text) + (StrideIn - StrideOut)) \ StrideIn) * StrideOut
CopyLen = StrideOut
End If
Spacify = Space$(OutLen)
OutPos = 1
For InPos = 1 To Len(Text) Step StrideIn
Mid$(Spacify, OutPos) = Mid$(Text, InPos, CopyLen)
OutPos = OutPos + StrideOut
Next
End Function
Example:
Private Sub Main()
Dim S As String
S = "0f030d"
Debug.Print """"; S; """"
S = Spacify(S, 2, 3)
Debug.Print """"; S; """"
S = Spacify(S, 3, 2)
Debug.Print """"; S; """"
S = Spacify(S, 2, 3, True)
Debug.Print """"; S; """"; " trimmed"
S = Spacify(S, 3, 2)
Debug.Print """"; S; """"
Debug.Print
S = "abc"
Debug.Print """"; S; """"
S = Spacify(S, 1, 2)
Debug.Print """"; S; """"
S = Spacify(S, 2, 1)
Debug.Print """"; S; """"
S = Spacify(S, 1, 2, True)
Debug.Print """"; S; """"; " trimmed"
S = Spacify(S, 2, 1)
Debug.Print """"; S; """"
Stop
End Sub
Result:
"0f030d"
"0f 03 0d "
"0f030d"
"0f 03 0d" trimmed
"0f030d"
"abc"
"a b c "
"abc"
"a b c" trimmed
"abc"
Try this:
Private Sub Form_Load()
Dim str As String
Dim newstr As String
str = "0F0D3E"
newstr = AddSpaces(str)
str = Replace(newstr, " ", "")
End Sub
Private Function AddSpaces(s As String) As String
Dim i As Integer
For i = 1 To Len(s) Step 2
AddSpaces = AddSpaces & Mid$(s, i, 2) & " "
Next
AddSpaces = Trim(AddSpaces)
End Function
This WORKS as expected on two Windows 10 systems (on a VM, the other a live PC). But on a third system (customer's, unfortunately) the form minimizes rather than being topmost.
SetwindowPos (TargetForm.hwnd, HWND_TOP,0,0,0,0, SWP_NOMOVE Or SWP_NOSIZE)
the Form (window) minimizes.
Any idea what would cause that?
This is a VB6 program (don't laugh!, I make a living on this program :)
UPDATE:
More details on code:
Set FormActive = frmToShow
frmToShow.Show
FormZorderSet frmToShow, Z_top
If Not frmPrevious Is Nothing Then
frmPrevious.Hide
End If
Public Function FormZorderSet(frmTarget As Form, Zorder As FormZorderType) As Long
FLAGS = SWP_NOMOVE Or SWP_NOSIZE
FormZorderSet = SetWindowPos(frmTarget.hwnd, Zorder, 0, 0, 0, 0, FLAGS)
Global declares
Public Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const HWND_TOPMOST = -1
Const HWND_TOP = 0
Try using this ontop function
'moudle code
Option Explicit
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Function SetTopMostWindow(hwnd As Long, Topmost As Boolean) _
As Long
If Topmost = True Then 'Make the window topmost
SetTopMostWindow = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, _
0, FLAGS)
Else
SetTopMostWindow = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, _
0, 0, FLAGS)
SetTopMostWindow = False
End If
End Function
Then for the use
'use
Dim lR As Long
Private Sub Form_Load()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'set form to allways on top
lR = SetTopMostWindow(Me.hwnd, True)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
This has worked for me in windows 10 without it minimizing my program.
for i = 0 to 23
'' ...
'' create 'line' control
'' ...
line.x1 = (inner_radius*cos(15 * i)) + centerx
line.y1 = (inner_radius*sin(15 * i)) + centery
line.x2 = (outer_radius*cos(15 * i)) + centerx
line.y2 = (outer_radius*sin(15 * i)) + centery
next
I'm using this algorithm to render many line controls to make something like the following:
The result is rather bizarre:
I think this happens due to the rounding of the cos() and sin() functions, so my question is, is there some algorithm I can apply to fix the rounding? Or is there a better way to render such controls, perhaps?
EDIT:
The problem, as pointed by Hrqls was that I was using degrees instead of radians... this is the function that I ended up using:
Sub ProgressAnim(ByVal centerx, _
ByVal centery, _
ByVal outer_radius, _
ByVal inner_radius, _
ByVal step_count, _
ByVal line_width)
Dim pi
Dim degstep
Dim scan
Dim newcontrol As Line
Dim controlid
pi = 4 * Atn(1)
degstep = pi / (step_count / 2)
For scan = 0 To step_count - 1
controlid = "line" & (scan + 1)
Set newcontrol = Me.Controls.Add("vb.line", controlid)
newcontrol.X1 = centerx + (inner_radius * Cos(degstep * scan))
newcontrol.Y1 = centery + (inner_radius * Sin(degstep * scan))
newcontrol.X2 = centerx + (outer_radius * Cos(degstep * scan))
newcontrol.Y2 = centery + (outer_radius * Sin(degstep * scan))
newcontrol.BorderStyle = 1
newcontrol.BorderWidth = line_width
newcontrol.Visible = True
Next
End Sub
Calling it like this
ProgressAnim 150, 250, 16, 9, 18, 1
produces this:
which is much closer to what I expected... sadly, I still don't know how to achieve anti-aliasing, but this will do. (For the moment, at least) :)
Your problem is that you calculate the angles in degrees while VB uses radians for its angles
have a look at the following project :
Option Explicit
Private Sub Form_Click()
DrawWheel
End Sub
Private Sub DrawWheel()
Dim intI As Integer
Dim sngRadius As Single
Dim sngRadiusY As Single
Dim sngCenterX As Single, sngCenterY As Single
Dim sngX1 As Single, sngY1 As Single
Dim sngX2 As Single, sngY2 As Single
Dim sngStep As Single
Dim sngAngle As Single
Dim sngCos As Single, sngSin As Single
'calculate form sizes
sngRadius = (ScaleWidth - 240) / 2
sngRadiusY = (ScaleHeight - 240) / 2
sngCenterX = 120 + sngRadius
sngCenterY = 120 + sngRadiusY
If sngRadiusY < sngRadius Then sngRadius = sngRadiusY
'draw circle
Circle (sngCenterX, sngCenterY), sngRadius
'calculate step between lines
sngStep = Atn(1) / 3
'draw lines
For intI = 0 To 23
'calculate angle for each line
sngAngle = sngStep * intI
'calculate coordinates for each line
sngCos = Cos(sngAngle)
sngSin = Sin(sngAngle)
sngX1 = sngCenterX + sngCos * sngRadius / 10
sngY1 = sngCenterY + sngSin * sngRadius / 10
sngX2 = sngCenterX + sngCos * sngRadius
sngY2 = sngCenterY + sngSin * sngRadius
'draw each lines
Line (sngX1, sngY1)-(sngX2, sngY2)
'print sequence number
Print CStr(intI)
Next intI
End Sub
Click on the form to draw the wheel
Atn(1) is PI/4 ... For 24 lines you need to divide 2*PI by 24 .. thus you need to divide PI by 12 ... which makes you divide Atn(1) by 3
change for i = 0 to 23 to for i = 0 to 21
and (15 * i) with (0.3 * i)
Try that code in form1 with a timer1:
Dim c As Integer, centerx As Integer, centery As Integer, inner_radius As Integer, outer_radius As Integer
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
Private Sub Form_Load()
c = 0
centerx = Form1.Width / 2
centery = Form1.Height / 2
inner_radius = 1200
outer_radius = 1
Timer1.Interval = 200
End Sub
Private Sub Timer1_Timer()
x1 = (inner_radius * Cos(0.3 * c)) + centerx
y1 = (inner_radius * Sin(0.3 * c)) + centery
x2 = (outer_radius * Cos(0.3 * c)) + centerx
y2 = (outer_radius * Sin(0.3 * c)) + centery
Line (x1, y1)-(x2, y2), RGB(0, 0, 0)
c = c + 1
If c = 21 Then Timer1.Enabled = False
End Sub
check your numbers in this example to see the drawing behavior.
I would ensure that you keep the greatest accuracy by using proper fractions of 2PI.
Fiddle with the constants until you get roughly what you want:
Option Explicit
Private Sub Form_Load()
Timer.Interval = 50
End Sub
Private Sub Timer_Timer()
DrawRadialLines
End Sub
Private Sub DrawRadialLines()
Const ksngPI As Single = 3.14159!
Const ksngCircle As Single = 2! * ksngPI
Const ksngInnerRadius As Single = 130!
Const ksngOuterRadius As Single = 260!
Const ksngCenterX As Single = 1200!
Const ksngCenterY As Single = 1200!
Const klSegmentCount As Long = 12
Const klLineWidth As Long = 3
Static s_lActiveSegment As Integer ' The "selected" segment.
Dim lSegment As Long
Dim sngRadians As Single
Dim sngX1 As Single
Dim sngY1 As Single
Dim sngX2 As Single
Dim sngY2 As Single
Dim cLineColour As OLE_COLOR
Me.DrawWidth = klLineWidth
' Overdraw previous graphic.
Me.Line (ksngCenterX - ksngOuterRadius - Screen.TwipsPerPixelX * 2, ksngCenterY - ksngOuterRadius - Screen.TwipsPerPixelY * 2)-(ksngCenterX + ksngOuterRadius + Screen.TwipsPerPixelX * 2, ksngCenterY + ksngOuterRadius + Screen.TwipsPerPixelY * 2), Me.BackColor, BF
For lSegment = 0 To klSegmentCount - 1
'
' Work out the coordinates for the line to be draw from the outside circle to the inside circle.
'
sngRadians = (ksngCircle * CSng(lSegment)) / klSegmentCount
sngX1 = (ksngOuterRadius * Cos(sngRadians)) + ksngCenterX
sngY1 = (ksngOuterRadius * Sin(sngRadians)) + ksngCenterY
sngX2 = (ksngInnerRadius * Cos(sngRadians)) + ksngCenterX
sngY2 = (ksngInnerRadius * Sin(sngRadians)) + ksngCenterY
' Work out how many segments away from the "current segment" we are.
' The current segment should be the darkest, and the further away from this segment we are, the lighter the colour should be.
Select Case Abs(Abs(s_lActiveSegment - lSegment) - klSegmentCount \ 2)
Case 0!
cLineColour = RGB(0, 0, 255)
Case 1!
cLineColour = RGB(63, 63, 255)
Case 2!
cLineColour = RGB(117, 117, 255)
Case Else
cLineColour = RGB(181, 181, 255)
End Select
Me.Line (sngX1, sngY1)-(sngX2, sngY2), cLineColour
Next lSegment
' Move the current segment on by one.
s_lActiveSegment = (s_lActiveSegment + 1) Mod klSegmentCount
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.