PrintPreviewDialog runs off page. I am using VB.net 2012 with PrintDocument and PrintPreviewDialog. I am getting data from a database. The data does not go to the next page. It appears as though it is just running off the bottom.
'Step through each record
'Load into memory
sHeader = objDataView(nRec).Item("PmtType").ToString
'Print the header
e.Graphics.DrawString(sHeader, ReportBodyFont, Brushes.Black, a, n)
n = n + 15
For nRec = 0 To nRecordCount
'Load into Text box
'e = refers to print page arguments
If sHeader = objDataView(nRec).Item("PmtType").ToString Then
'I'm in the same category, print it
dDate = objDataView(nRec).Item("DatePd").ToString
sString = Format(dDate, "MM/dd/yy")
e.Graphics.DrawString(sString, ReportBodyFont, Brushes.Black, b, n)
e.Graphics.DrawString(objDataView(nRec).Item("PaidTo").ToString, ReportBodyFont, Brushes.Black, c, n)
sPmt = objDataView(nRec).Item("Payment").ToString
sPmt = FormatNumber(sPmt, 2)
e.Graphics.DrawString(sPmt, ReportBodyFont, Brushes.Black, d, n)
e.Graphics.DrawString(objDataView(nRec).Item("Comments").ToString, ReportBodyFont, Brushes.Black, ee, n)
n = n + iSpace
nSubtot = nSubtot + objDataView(nRec).Item("Payment").ToString
nGrandTot = nGrandTot + objDataView(nRec).Item("Payment")
Else
'I moved to the next category, skip a line and print a new category
'Print the sub total, reset to 0, print the next category
e.Graphics.DrawString("Sub Total:", ReportBodyFont, Brushes.Black, c, n)
nSubtot = FormatNumber(nSubtot, 2)
e.Graphics.DrawString(nSubtot, ReportBodyFont, Brushes.Black, d, n)
nSubtot = 0
n = n + 15
sHeader = objDataView(nRec).Item("PmtType").ToString
e.Graphics.DrawString(sHeader, ReportBodyFont, Brushes.Black, a, n)
n = n + 15
dDate = objDataView(nRec).Item("DatePd").ToString
sString = Format(dDate, "MM/dd/yy")
e.Graphics.DrawString(sString, ReportBodyFont, Brushes.Black, b, n)
e.Graphics.DrawString(objDataView(nRec).Item("PaidTo").ToString, ReportBodyFont, Brushes.Black, c, n)
sPmt = objDataView(nRec).Item("Payment").ToString
sPmt = FormatNumber(sPmt, 2)
e.Graphics.DrawString(sPmt, ReportBodyFont, Brushes.Black, d, n)
e.Graphics.DrawString(objDataView(nRec).Item("Comments").ToString, ReportBodyFont, Brushes.Black, ee, n)
n = n + iSpace
nSubtot = nSubtot + objDataView(nRec).Item("Payment").ToString
nGrandTot = nGrandTot + objDataView(nRec).Item("Payment").ToString
End If
'Test for page break
If nRec < nRecordCount Then
e.HasMorePages = True
Else
e.HasMorePages = False
End If
Next
'Test for page break
That does not test for a page break. First you need to move the nRec variable out of the method and use the BeginPrint event to start it at 0:
Private nRec As Integer
Private Sub PrintDocument1_BeginPrint(sender As Object, e As Printing.PrintEventArgs)
nRec = 0
End Sub
Your PrintPage event handler increments nRec only after checking that the text still fits on the page:
Private Sub PrintDocument1_PrintPage(sender As Object, e As Printing.PrintPageEventArgs)
'' Print header
''...
While nRec < nRecordCount
'' Does it still fit on the page?
If n + iSpace > e.PageBounds.Bottom Then
e.HasMorePages = True
Return
End If
'' Print next record
nRec += 1
''...
End While
End Sub
Related
The following code has kicked around with me for many years. I do not know where I picked it up and for the most part it worked, when it worked. However, I have tried to use it on a new document. It worked once then didn't work again. I have tried to add the VB reference to Regular Expressions 5.5 but that was not correct. I was hoping for an easy fix.
The concept of the function was to display the content of a cell as an evaluated equation. It was to "show my work" so to speak so that in complex sheets, checking would be easier.
Unfortunately, the vbscript in the function is a black box to me.
Old Code
Option Explicit
Function SF(r As Range, Z As Integer) As String
Debug.Print r, Z
Const crep As String = "(([A-Za-z0-9_]+|'[^']+')!)?\$?[A-Z]{1,2}\$?[0-9]+"
Const mrep As String = "(([A-Za-z0-9_]+:[A-Za-z0-9_]+|'[^']+:[^']+')\!)|(\$?[A-Z]{1,2}\$?[0-9]+:\$?[A-Z]{1,2}\$?[0-9]+)"
Dim v As Variant, n As Long
Dim regex As Object, matches As Object, m As Object
SF = Mid(r.formula, 2)
Set regex = CreateObject("vbscript.regexp")
regex.Global = True
regex.Pattern = mrep
Set matches = regex.Execute(SF)
If matches.Count > 0 Then Exit Function
regex.Pattern = crep
Set matches = regex.Execute(SF)
n = matches.Count - 1
For n = n To 0 Step -1
Set m = matches.Item(n)
If InStr(m.Value, "!") = 0 Then v = Evaluate("'" & r.Parent.Name & "'!" & m.Value)
If IsNumeric(Val(v)) = True Then
v = Application.WorksheetFunction.Round(v, Z)
End If
SF = Left(SF, m.FirstIndex) & CStr(v) & _
Mid(SF, m.FirstIndex + m.Length + 1)
Next n
SF = "{ =" & SF & "}"
End Function
Updated Code-ish
Function SF(r As Range, Z As Integer) As String
Debug.Print r, Z
Const crep As String = "(([A-Za-z0-9_]+|'[^']+')!)?\$?[A-Z]{1,2}\$?[0-9]+"
Const mrep As String = "(([A-Za-z0-9_]+:[A-Za-z0-9_]+|'[^']+:[^']+')\!)|(\$?[A-Z]{1,2}\$?[0-9]+:\$?[A-Z]{1,2}\$?[0-9]+)"
Dim v As Variant, n As Long
SF = Mid(r.formula, 2)
n = InStr(SF, crep)
While n > 0
If InStr(Mid(SF, n), "!") = 0 Then
v = Evaluate("'" & r.Parent.Name & "'!" & Mid(SF, n, InStr(SF, crep) - n + Len(crep)))
If IsNumeric(Val(v)) = True Then
v = Application.WorksheetFunction.Round(v, Z)
End If
SF = Left(SF, n - 1) & CStr(v) & Mid(SF, n + Len(crep) + 1)
End If
n = InStr(SF, crep)
Wend
SF = "{ =" & SF & "}"
End Function
I can assume that this is not the first time this type of code has been written. Above is an attempt but the cell address is displayed and not the cell value. When referencing a named cell, it just shows the cell name.
Any thoughts? Am I going in the correct direction?
I have an Excel sheet with two sets of cells that require user input. The first set has 8 inputs, the second set has 5.
Let's say the Data Sets One and Two have user inputs of letters, like so:
DataSetOne(0) = A
DataSetOne(1) = B
DataSetOne(2) = C
DataSetOne(3) = D
DataSetOne(4) = E
DataSetOne(5) = F
DataSetOne(6) = G
DataSetOne(7) = H
DataSetTwo(0) = A
DataSetTwo(1) = B
DataSetTwo(2) = H
DataSetTwo(3) = D
DataSetTwo(4) = C
I need to check for replicated data. I only care if any two consecutive values are repeated, not just single values.
For example, Data Set One contains seven sequential "pairs" of input data:
Pair 1 = A, B
Pair 2 = B, C
Pair 3 = C, D
Pair 4 = D, E
Pair 5 = E, F
Pair 6 = F, G
Pair 7 = G, H
And similarly, Data Set Two has four additional pairs of data:
Pair 8 = A, B
Pair 9 = B, H
Pair 10 = H, D
Pair 12 = D, C
I need to see if any of these pairs match. Order does not matter - as long as two pairs have the same two individual inputs, I need to make a decision one way. If the pairs do not contain both matching values, then my decision goes a different way.
So in the above example, there are matches between:
Pair 1 and Pair 8
Pair 3 and Pair 12
To find the duplicates, i.e. values present in both of the lists, the easiest way to implement is to simply do a brute force search iterating over both lists. Depending on your application, this may be good enough.
For example:
Public Sub SO70184805_find_duplicates()
Dim DataSetOne(0 To 7) As String
Dim DataSetTwo(0 To 4) As String
Const Delimiter As String = ", "
DataSetOne(0) = "A"
DataSetOne(1) = "B"
DataSetOne(2) = "C"
DataSetOne(3) = "D"
DataSetOne(4) = "E"
DataSetOne(5) = "F"
DataSetOne(6) = "G"
DataSetOne(7) = "H"
DataSetTwo(0) = "A"
DataSetTwo(1) = "B"
DataSetTwo(2) = "H"
DataSetTwo(3) = "D"
DataSetTwo(4) = "C"
Dim PairsOne(0 To 6) As String
Dim PairsTwo(0 To 3) As String
Dim I As Integer
Dim S1 As Variant
Dim S2 As Variant
'Make the lists of pairs
Debug.Print "Pairs from the first list:"
For I = 0 To 6
If (DataSetOne(I) < DataSetOne(I + 1)) Then
PairsOne(I) = DataSetOne(I) & Delimiter & DataSetOne(I + 1)
Else
PairsOne(I) = DataSetOne(I + 1) & Delimiter & DataSetOne(I)
End If
Debug.Print (PairsOne(I))
Next I
Debug.Print
Debug.Print "Pairs from the second list:"
For I = 0 To 3
If (DataSetTwo(I) < DataSetTwo(I + 1)) Then
PairsTwo(I) = DataSetTwo(I) & Delimiter & DataSetTwo(I + 1)
Else
PairsTwo(I) = DataSetTwo(I + 1) & Delimiter & DataSetTwo(I)
End If
Debug.Print (PairsTwo(I))
Next I
Debug.Print
Debug.Print ("Duplicates:"):
Dim NumberOfDuplicates As Integer
NumberOfDuplicates = 0
For Each S1 In PairsOne
For Each S2 In PairsTwo
If (S1 = S2) Then
Debug.Print (S1)
NumberOfDuplicates = NumberOfDuplicates + 1
End If
Next
Next
End Sub
This is the output:
Pairs from the first list:
A, B
B, C
C, D
D, E
E, F
F, G
G, H
Pairs from the second list:
A, B
B, H
D, H
C, D
Duplicates:
A, B
C, D
Something along these lines, i'm heading off home now so can't do much more. I'll revisit later if possible. You'll need to add the scripting runtime reference to use the dictionary.
Sub datasets()
Dim datasetone(7) As String
Dim datasettwo(4) As String
Dim dicPairsOne As New Scripting.Dictionary
Dim dicPairsTwo As New Scripting.Dictionary
Dim l As Long
Dim strPair As String
datasetone(0) = "A"
datasetone(1) = "B"
datasetone(2) = "C"
datasetone(3) = "D"
datasetone(4) = "E"
datasetone(5) = "F"
datasetone(6) = "G"
datasetone(7) = "H"
datasettwo(0) = "A"
datasettwo(1) = "B"
datasettwo(2) = "H"
datasettwo(3) = "D"
datasettwo(4) = "C"
For l = 0 To UBound(datasetone) - 1
strPair = datasetone(l) & "," & datasetone(l + 1)
If Not dicPairsOne.Exists(strPair) Then
dicPairsOne.Add strPair, 1
Else
dicPairsOne(strPair) = dicPairsOne(strPair) + 1
End If
If Not dicPairsOne.Exists(StrReverse(strPair)) Then
dicPairsOne.Add StrReverse(strPair), 1
Else
dicPairsOne(StrReverse(strPair)) = dicPairsOne(StrReverse(strPair)) + 1
End If
Next l
For l = 0 To UBound(datasettwo) - 1
strPair = datasettwo(l) & "," & datasettwo(l + 1)
If Not dicPairsTwo.Exists(strPair) Then
dicPairsTwo.Add strPair, 1
Else
dicPairsTwo(strPair) = dicPairsTwo(strPair) + 1
End If
Next l
For l = 0 To dicPairsOne.Count - 1
If dicPairsTwo.Exists(dicPairsOne.Keys()(l)) Then
Debug.Print dicPairsOne.Keys()(l)
End If
Next l
End Sub
When I execute this it will delete the "Refined" lines and when I comment this function out it the "Refined" lines don't get deleted. I inherited this code and I have added every section to has "Refined" because I'm attempting to add extra products besides "gas" and "oil" but I really don't know VBA or programming. I've just been winging it and it's mostly worked except this section.
My question is what's wrong with what I added to the code? I edited or added every line that has the word "refined" in it. It works as intended for oil and gas but will always delete the refined column. When it executes data for oil, gas, and refined populates the worksheet but it will instantly delete all the refined columns that it pulled in.
I don't have the proficient to rewrite it as a different do until loop without some sort of code template.
This function checks the Current Prices tab for any columns that are duplicates of the day before or weekends and deletes the column
Function PricesCleanup() As Boolean
Dim r, c As Integer
Dim removeCount As Integer
Dim removeColumn As Boolean
Dim isGas, isOil, isRefined As Boolean
c = FIRSTDATA_COL
removeCount = 0
Do Until IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, c)) 'check every col of prices
'Start at the row of the first date and reset remove flag
r = FIRSTDATE_ROW
removeColumn = True
'Check each column, at least until there is a discrepancy between prices so we know it's not a holiday
Do Until ((r > 12 And IsEmpty(ws_currentprices.Cells(r, c))) Or r > 60 Or Not removeColumn)
'If the prices don't match, we know it's not a holiday
If (ws_currentprices.Cells(r, c) <> ws_currentprices.Cells(r, c + 1)) Then
'If the first row is empty or matches second row, it's likely due to near EoM index shifting and requires special handling
If r = FIRSTDATE_ROW Then
If IsEmpty(ws_currentprices.Cells(r, c)) Then
'Oil index swap
removeColumn = False
End If
If (ws_currentprices.Cells(r, c) = ws_currentprices.Cells(r + 1, c) And ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Gas") Then
'Gas index swap so clear cell and allow to continue but only if within the last few workdays of the month
If (DateDiff("d", WorksheetFunction.WorkDay(ws_currentprices.Cells(r, BUCKET_COL), -1), ws_currentprices.Cells(ASOFDATE_ROW, c)) > -3) Then
ws_currentprices.Cells(r, c).ClearContents
End If
End If
Else
'Not index related and no match, so don't remove column
removeColumn = False
End If
End If
r = r + 1
Loop
'Check for weekend dates or dates from prior month
If Weekday(ws_currentprices.Cells(ASOFDATE_ROW, c)) = 1 Or Weekday(ws_currentprices.Cells(ASOFDATE_ROW, c)) = 7 Or Month(ws_currentprices.Cells(ASOFDATE_ROW, c)) <> Month(ws_currentprices.Cells(ASOFDATE_ROW, BUCKET_COL)) Then
removeColumn = True
End If
'Remove column if flagged
If removeColumn Then
removeCount = removeCount + 1
ws_currentprices.Columns(c).EntireColumn.Delete
c = c - 1
End If
'Copy up spot price
If Not IsEmpty(ws_currentprices.Cells(FIRSTDATE_ROW, c)) Then
ws_currentprices.Cells(SPOT_ROW, c) = ws_currentprices.Cells(FIRSTDATE_ROW, c)
ElseIf Not IsEmpty(ws_currentprices.Cells(FIRSTDATE_ROW + 1, c)) Then
ws_currentprices.Cells(SPOT_ROW, c) = ws_currentprices.Cells(FIRSTDATE_ROW + 1, c)
Else
ws_currentprices.Cells(SPOT_ROW, c) = ""
End If
c = c + 1
Loop
'Check if any columns are left and return bool value
isGas = False
isOil = False
isRefined = False
c = FIRSTDATA_COL
Do Until IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, c))
If (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Gas") Then
isGas = True
ElseIf (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Oil") Then
isOil = True
ElseIf (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Refined") Then
isRefined = True
End If
c = c + 1
Loop
If (isGas And isOil And isRefined) Then
PricesCleanup = True
Else
PricesCleanup = False
End If
End Function
Basically I need this Visual Basic code translated to Basic4Android code.
What I want to do is to randomly assign to 16 buttons values from 1-15 and one empty. Each time they will be different. I've done it in VB and it works but know I want to make this on Android.
Sub Shuffle()
Dim a(15), i, j, RN As Integer
Dim flag As Boolean
flag = False
i = 1
a(j) = 1
Do While i <= 15
Randomize()
RN = CInt(Int((15 * Rnd()) + 1))
For j = 1 To i
If (a(j) = RN) Then
flag = True
Exit For
End If
Next
If flag = True Then
flag = False
Else
a(i) = RN
i = i + 1
End If
Loop
Form1.Button1.Text = a(1)
Form1.Button2.Text = a(2)
Form1.Button3.Text = a(3)
Form1.Button4.Text = a(4)
Form1.Button5.Text = a(5)
Form1.Button6.Text = a(6)
Form1.Button7.Text = a(7)
Form1.Button8.Text = a(8)
Form1.Button9.Text = a(9)
Form1.Button10.Text = a(10)
Form1.Button11.Text = a(11)
Form1.Button12.Text = a(12)
Form1.Button13.Text = a(13)
Form1.Button14.Text = a(14)
Form1.Button15.Text = a(15)
Form1.Button16.Text = ""
End Sub
I know only to change "Integer" to "Int" and delete all "Form1's". I can't use Randomize() nor CInt nor Int statements because they give me errors.
Hope this helps. its code for getting random number without repeating.
you can change i as per your requirement.
Sub Activity_Create(FirstTime As Boolean)
dim l as list
l.Initialize
Dim i As Int = 1
Do While i < 17
Dim x As Int
x = Rnd(1,17)
If l.IndexOf(x) = -1 Then
l.Add(x)
i = i + 1
Else
Log("DUPLICATE:" & x)
End If
Loop
For i = 0 To l.Size -1
Log(l.Get(i))
Next
End Sub
I am trying to do some prime factorisation with my VBA excel and I am hitting the limit of the long data type -
Runtime Error 6 Overflow
Is there any way to get around this and still stay within VBA? I am aware that the obvious one would be to use another more appropriate programming language.
Lance's solution works in so far that I am able to get the big numbers into the variables now. However, when I try to apply the MOD function - bignumber MOD 2, for example - it still fails with error message
Runtime Error 6 Overflow
You can use Decimal data type. Quick hint from google: http://www.ozgrid.com/VBA/convert-to-decimal.htm
This is my Decimals.cls (VB6):
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Decimals"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'local variable(s) to hold property value(s)
Private mvarDec As Variant 'local copy
Public Property Let Dec(ByVal vData As Variant)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Dec = 5
mvarDec = CDec(vData)
End Property
Public Property Get Dec() As Variant
Attribute Dec.VB_UserMemId = 0
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.Dec
Dec = CDec(mvarDec)
End Property
and this is a testing program. The class has been setup so that you don't have to qualify with .Dec() on get and let.
Dim dec1 As New Std.Decimals
Dim dec2 As New Std.Decimals
Dim dec3 As New Std.Decimals
Dim modulus As New Std.Decimals
Sub main()
dec1 = "1000.000000001"
dec2 = "1000.00000000000001"
dec3 = dec1 + dec2
Debug.Print dec1
Debug.Print dec2
Debug.Print dec3
Debug.Print dec3 * dec3
Debug.Print dec3 / 10
Debug.Print dec3 / 100
Debug.Print Sqr(dec3)
modulus = dec1 - Int(dec1 / dec2) * dec2
Debug.Print modulus
End Sub
and sample run
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999
1000.000000001
1000.00000000000001
2000.00000000100001
4000000.000004000040000001
200.000000000100001
20.0000000000100001
44.721359550007
0.00000000099999
Here is my "big multiply" routine for multiplying arbitrarily large numbers (eg 100 characters long). It works by splitting the input numbers, which are strings, into chunks of 7 digits (because then it can cross multiply them and store the results in Doubles).
eg bigmultiply("1934567803945969696433","4483838382211678") = 8674289372323895422678848864807544574
Function BigMultiply(ByVal s1 As String, ByVal s2 As String) As String
Dim x As Long
x = 7
Dim n1 As Long, n2 As Long, n As Long
n1 = Int(Len(s1) / x + 0.999999)
n2 = Int(Len(s2) / x + 0.999999)
n = n1 + n2
Dim i As Long, j As Long
ReDim za1(n1) As Double
i = Len(s1) Mod x
If i = 0 Then i = x
za1(1) = Left(s1, i)
i = i + 1
For j = 2 To n1
za1(j) = Mid(s1, i, x)
i = i + x
Next j
ReDim za2(n2) As Double
i = Len(s2) Mod x
If i = 0 Then i = x
za2(1) = Left(s2, i)
i = i + 1
For j = 2 To n2
za2(j) = Mid(s2, i, x)
i = i + x
Next j
ReDim z(n) As Double
Dim u1 As Long, u2 As Long
Dim e As String
e = String(x, "0")
For u1 = 1 To n1
i = u1
For u2 = 1 To n2
i = i + 1
z(i) = z(i) + za1(u1) * za2(u2)
Next u2
Next u1
Dim s As String, y As Double, w As Double, m As Long
m = n * x
s = String(m, "0")
y = 10 ^ x
For i = n To 1 Step -1
w = Int(z(i) / y)
Mid(s, i * x - x + 1, x) = Format(z(i) - w * y, e)
z(i - 1) = z(i - 1) + w
Next i
'truncate leading zeros
For i = 1 To m
If Mid$(s, i, 1) <> "0" Then Exit For
Next i
If i > m Then
BigMultiply = ""
Else
BigMultiply = Mid$(s, i)
End If
End Function
MOD is trying to convert your DECIMAL type to LONG before operating on it. You may need to write your own MOD function for the DECIMAL type. You might try this:
r = A - Int(A / B) * B
where A & B are DECIMAL subtype of VARIANT variables, and r might have to be that large also (depending on your needs), though I only tested on a long.