Finding unique partitions for a number - unique

I am using below code for finding partitions for a given number (N). How can I ensure only unique partitions? For instance partitions (1, 1, 1, 7), (1, 1, 7, 1), (1, 7, 1, 1) and (7, 1, 1, 1) would be considered the same and only one of these should be output.
Thanks
Regards
Dim N = 10
For i As Integer = 0 To N
For j As Integer = 0 To N
For k As Integer = 0 To N
For l As Integer = 0 To N
If i + j + k + l = N Then
Dim St As String = String.Format("({0:d}, {1:d}, {2:d}, {3:d})", i, j, k, l)
Console.WriteLine(St)
End If
Next
Next
Next
Next
Console.Read()
EDIT: Below seems to be working from someone's suggestion;
Module Module1
Sub Main()
Console.WriteLine("Please enter an integer.")
Dim sReadLine As String = Console.ReadLine()
Dim iValue As Integer
If IsNumeric(sReadLine) Then
iValue = CInt(sReadLine)
Else
Console.WriteLine("'" & sReadLine & "' is not a numeric value. Press any key to exit.")
'Application.Exit()
Console.Read()
Exit Sub
End
End If
Console.Clear()
Console.WriteLine("Number is {0}", iValue)
Console.WriteLine("")
Partitions1(iValue)
Exit Sub
End Sub
Dim partitions As New List(Of Part)
Private Sub Partitions1(N As Integer)
For i As Integer = 0 To N
For j As Integer = 0 To N
For k As Integer = 0 To N
For l As Integer = 0 To N
If i + j + k + l = N Then
Dim thisPartition As New Part()
thisPartition.Parts = New Integer() {i, j, k, l}
If Not partitions.Contains(thisPartition) Then
partitions.Add(thisPartition)
End If
End If
Next
Next
Next
Next
For Each x In partitions
Dim St = "("
For Each y In x.Parts
St = St & y & ", "
Next
St = Left(St, Len(St) - 2)
St = St & ")"
Console.WriteLine(St)
Next
Console.WriteLine("")
Console.WriteLine("{0} unique partititons found.", partitions.Count)
Console.Read()
End Sub
Public Class Part 'Sorted array of integer with comparer
Implements IEquatable(Of Part)
Public Property Parts As Integer()
Get
Return m_Parts
End Get
Set(value As Integer())
m_Parts = value
Array.Sort(m_Parts)
End Set
End Property
Private m_Parts As Integer()
Public Overloads Function Equals(other As Part) As Boolean _
Implements IEquatable(Of Part).Equals
If other Is Nothing Then
Return False
End If
If other.Parts.GetLength(0) <> m_Parts.GetLength(0) Then Return False
Dim result As Boolean = True
Array.Sort(other.Parts)
For I As Integer = 0 To other.Parts.GetLength(0) - 1
If other.Parts(I) <> m_Parts(I) Then
result = False
Exit For
End If
Next
Return result
End Function
' Should also override == and != operators.
End Class
End Module

Collect the found solutions in a list, then writen an algo which eliminates the duplicates from the list and then print the list.

Related

Print data grid view skips the first row

I have created a print preview for the data grid view that I want to print. The code works fine but there is slight problem
Problem Screenshot:
In the data grid view row, the ID 1 is missing, it always starts from 2. How can I solve this problem? Please help.
My code:
Private Sub PrintDocument1_PrintPage(sender As System.Object, e As System.Drawing.Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage
Dim mRow As Integer = 0
Dim newpage As Boolean = True
PrintDocument1.DefaultPageSettings.Landscape = True
With DataGridView1
Dim fmt As StringFormat = New StringFormat(StringFormatFlags.LineLimit)
fmt.LineAlignment = StringAlignment.Center
fmt.Trimming = StringTrimming.EllipsisCharacter
Dim y As Single = e.MarginBounds.Top
Do While mRow < .RowCount
Dim row As DataGridViewRow = .Rows(mRow)
Dim x As Single = e.MarginBounds.Left
Dim h As Single = 0
For Each cell As DataGridViewCell In row.Cells
Dim rc As RectangleF = New RectangleF(x, y, cell.Size.Width, cell.Size.Height)
e.Graphics.DrawRectangle(Pens.Black, rc.Left, rc.Top, rc.Width, rc.Height)
If (newpage) Then
e.Graphics.DrawString(DataGridView1.Columns(cell.ColumnIndex).HeaderText, .Font, Brushes.Black, rc, fmt)
Else
e.Graphics.DrawString(DataGridView1.Rows(cell.RowIndex).Cells(cell.ColumnIndex).FormattedValue.ToString(), .Font, Brushes.Black, rc, fmt)
End If
x += rc.Width
h = Math.Max(h, rc.Height)
Next
newpage = False
y += h
mRow += 1
If y + h > e.MarginBounds.Bottom Then
e.HasMorePages = True
mRow -= 1
newpage = True
Exit Sub
End If
Loop
mRow = 0
End With
End Sub
rows(0) is the first data row, not header row, while cell.RowIndex is 1, so change rows(cell.RowIndex) as rows(cell.RowIndex-1) :
e.Graphics.DrawString(DataGridView1.Rows(cell.RowIndex - 1).Cells(cell.ColumnIndex).FormattedValue.ToString(), .Font, Brushes.Black, rc, fmt)
The If (newpage) causes it to draw the headers instead of the first row.
You could change the section
newpage = False
y += h
mRow += 1
to
If not newpage Then
mRow += 1
End If
newpage = False
y += h
Print each part separately to avoid this kind of problems. The headers part belongs to the Columns collection then print it first before you handle the Rows and Cells parts.
You have another problem in your code to fix. The mRow is a local variable that does not preserve the last printed row to skip or the new row to continue with when you request a new page. It must be a class field.
Private mRow As Integer
Private Sub PrintPreviewButton(sender As Object, e As EventArgs) _
Handles Button1.Click
PrintDocument1.DefaultPageSettings.Landscape = True
mRow = 0
Using d = New PrintPreviewDialog With {
.Document = PrintDocument1
}
d.ShowDialog(Me)
End Using
End Sub
Private Sub PrintDocument1_PrintPage(sender As Object, e As PrintPageEventArgs) _
Handles PrintDocument1.PrintPage
Dim g = e.Graphics
Dim x As Integer = e.MarginBounds.X
Dim y As Integer = e.MarginBounds.Y
With DataGridView1
Using sf = New StringFormat(StringFormat.GenericTypographic) With {
.LineAlignment = StringAlignment.Center,
.Trimming = StringTrimming.EllipsisCharacter
}
For Each col As DataGridViewColumn In .Columns
Dim rect = New Rectangle(
x, y,
col.Width, col.DataGridView.ColumnHeadersHeight)
g.DrawRectangle(Pens.Black, rect)
rect.Inflate(-3, 0)
g.DrawString(col.HeaderText, .Font, Brushes.Black, rect, sf)
x += col.Width
Next
y += .ColumnHeadersHeight
For i = mRow To .RowCount - 1
Dim row = .Rows(i)
If row.IsNewRow Then Exit Sub
x = e.MarginBounds.X
For Each cell As DataGridViewCell In row.Cells
Dim rect = New Rectangle(New Point(x, y), cell.Size)
g.DrawRectangle(Pens.Black, rect)
rect.Inflate(-3, 0)
g.DrawString(cell.FormattedValue?.ToString(),
.Font, Brushes.Black, rect, sf)
x += cell.Size.Width
Next cell
y += row.Height
If y + row.Height > e.MarginBounds.Bottom Then
mRow = i + 1
e.HasMorePages = True
Exit For
End If
Next i
End Using
End With
End Sub

Excel VBA: parsing JSON

Hope somebody might able to help me.
I am a real rookie in this field, had a friend of mine write up the following code some time ago.
I have VB in Excel that gets data from a yahoo API, URL: "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
The data gets inserted in excel and is auto-refreshed every minute.
Everything works smoothly with no issues.
Now to the challange, since the data gets auto purged after a day in the excel, I would need to extend the amount of data (rows) from the current 1 day to 7 days.
So I tried simply to change the URL from the above mentioned to the following:
"https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=7d"
However the parsing in the code gives me errors which I am to bad at solving..
First warning comes in the code:
"Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)"
And the whole code is as below (feel free to try it in excel if you would like), thanks in advance.
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{": ParseObj key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|
[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .TEST(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.Value
If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
Debug.Print s
End Function
Function GetFilteredValues(dic, match)
Dim c&, i&, v, w
v = dic.keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
Function toUnix(dt) As Long
toUnix = DateDiff("s", "1/1/1970 00:00:00", dt)
End Function
Function fromUnix(ts) As Date
fromUnix = DateAdd("s", ts, "1/1/1970 00:00:00")
End Function
Private Sub GetData()
' Queue next invocation
Application.OnTime Now + TimeValue("00:01:00"), "GetData"
Dim DataSheet As Worksheet
Set DataSheet = Sheets("Data")
Dim ParameterSheet As Worksheet
Set ParameterSheet = Sheets("Parameters")
Dim scrape As String
scrape = ParameterSheet.Range("B2").Value
If scrape <> "TRUE" Then
Exit Sub
End If
Dim ticker As String
ticker = ParameterSheet.Range("A2").Value
Dim url As String
url = "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
Dim hReq As Object
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", url, False
.Send
End With
Dim json As Object
Set json = ParseJSON(hReq.ResponseText)
Dim closes As Variant
closes = GetFilteredValues(json, "*.close*")
Dim opens As Variant
opens = GetFilteredValues(json, "*.open*")
Dim volumes As Variant
volumes = GetFilteredValues(json, "*.volume*")
Dim highs As Variant
highs = GetFilteredValues(json, "*.high*")
Dim lows As Variant
lows = GetFilteredValues(json, "*.low*")
Dim timestamps As Variant
timestamps = GetFilteredValues(json, "*.timestamp*")
Dim i As Integer
i = UBound(timestamps) + 1
Dim row As Integer
row = 2
' Load new data in
Dim timestamp As Variant
For Each timestamp In timestamps
i = i - 1
timestamp = Int(timestamps(i) / 60) * 60
If "null" = closes(i) Then
GoTo Continue
End If
If DataSheet.Range("H" & row).Value = "" Then
' Empty dataset
ElseIf toUnix(DataSheet.Range("H" & row).Value) < timestamp Then
' There is new data, prepend
DataSheet.Rows(row).Insert
ElseIf toUnix(DataSheet.Range("H" & row).Value) = timestamp Then
' Replace old data,
Else: GoTo Continue
End If
DataSheet.Range("B" & row).Value = ticker
DataSheet.Range("C" & row).Value = opens(i)
DataSheet.Range("D" & row).Value = highs(i)
DataSheet.Range("E" & row).Value = lows(i)
DataSheet.Range("F" & row).Value = closes(i)
DataSheet.Range("G" & row).Value = volumes(i)
DataSheet.Range("H" & row).Value = fromUnix(timestamp)
row = row + 1
Continue:
Next timestamp
' Remove data that is more then 10 days old
row = 1
Do While True
row = row + 1
Dim datee As Variant
datee = DataSheet.Range("H" & row).Value
If datee = "" Then
Exit Do
End If
If toUnix(datee) + 864000 < toUnix(Now()) Then
DataSheet.Rows(row).EntireRow.Delete
row = row - 1 ' This prevents skipping the next line
End If
Loop
End Sub
Private Sub Auto_Open()
GetData
End Sub
Problem is the parsing code cannot deal with the multiple trading periods which in the JSON are arrays within arrays [[{}],[{}],[{}]] when the range is greater than 1 day. The array index counter e is reset at each opening bracket so you get identical keys for each trading period. Dictionary keys must be unique hence the error. The best solution would be to rewrite using a modern parser but as a quick-fix hack the ParseArr function as follows ;
Function ParseArr(key$)
'Dim e& move to top of script
' add this line
If InStr(1, key, "tradingPeriods") = 0 Then e = 0
Do: p = p + 1
' no change to this code
Loop
End Function

Search string in between HTML tags and replace

Newbie here. I have an HTML source code and would like to look for string in between header tags <h1></h1>, <h2></h2>till <h5></h5> and then convert the text to lower case except acronyms or abbreviations (these are all capitals in 2 or more characters). And make sure that all country names in between use proper case.
As an example: It will find <h1>HR Policies and Procedures for Hiring - argentina LTD</h1>
It will convert it to:<H1>HR policies and procedures for hiring - Argentina LTD</H1>
I've tried a user defined function for Excel VBA found online: CapIt(A2). It uses Search, Split and Join. I'm not able to put them together to come up with the result. Would appreciate very much your help. Thank you.
Code I saw online as initial reference:
Function Capit(s As String)
Dim v As Variant, j As Long
v = Split(s, " ") ' separates the words
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capit = Join(v, " ") ' joins the words
End Function
'Added this code below, can we use the results to lowercase the string and exclude the output in this function
Function FindAcronyms(yourWord As String)
Dim I As Integer
Dim ctr As Integer
FindAcronyms = Null
For I = 1 To Len(yourWord)
If Asc(Mid(yourWord, I, 1)) <= 90 And _
Asc(Mid(yourWord, I, 1)) >= 65 Then
If ctr > 0 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
ctr = ctr + 1
Else
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1) & ", "
End If
ctr = 0
End If
Next
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
If Right(FindAcronyms, 2) = ", " Then
FindAcronyms = Left(FindAcronyms, Len(FindAcronyms) - 2)
End If
End Function
'the final look would be something like this
Sub TitleChange()
'define array
myarray = Range("A1:A100")
' Define the pattern
Dim pattern As String: pattern = "<h*>*</h*>" 'looks for the header tags
Dim f As Variant
For Each f In myarray
If f Like pattern = True Then Capital (f) 'changes all string to lower case except countries (to retain proper case) and acronyms (to retain uppercase)
Next f
End Sub
You can include the countries in an array
Sub Test()
Debug.Print Capital("HR Policies and Procedures for Hiring - argentina LTD")
End Sub
Function Capital(ByVal s As String)
Dim a, v As Variant, j As Long
a = Array("Argentina", "Egypt", "Enland")
v = Split(s, " ")
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbLowerCase)
If Not IsError(Application.Match(v(j), a, 0)) Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capital = Join(v, " ")
End Function
Added UDF that parses HTML code, used the Sub Test above as UDF Capital and UDF to bring together. Welcome suggestions to make it cleaner or more efficient
Dim rng As Range, cell As Range
Set rng = Range("A1:A5")
' Define the pattern
Dim pattern As String: pattern = "*<h?>*</h?>*"
' Check each item against the pattern
For Each cell In rng
If (cell Like pattern = True) Then
cell.Offset(0, 16).Value = cell.Value
cell.Offset(0, 16).Value = joinCell(Capital(StripHTML(cell)), cell.Offset(0, 0).Value) 'used UDF for striping innertext, applying rules and joining back string
End If
Next cell
End Sub

How to print Datagridview has a table in VB

I have a Datagrid with information retrieved from a database and i would like the print output to be in table format with lines and columns. My actual methode is simple but the output is very confusing. Any thoughts?
Private Sub Imprimir_Click(sender As Object, e As EventArgs) Handles Imprimir.Click
PrintPreviewDialog1.PrintPreviewControl.Zoom = 1.0
PrintPreviewDialog1.FindForm.WindowState = FormWindowState.Maximized
PrintPreviewDialog1.ShowDialog()
End Sub
Private Sub PrintDocument1_PrintPage(ByVal sender As System.Object, ByVal e As
System.Drawing.Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage
Dim y As Integer = 70
PrintDocument1.DefaultPageSettings.Landscape = True
e.Graphics.DrawString("TransporGest - Registo de Operações",
New Font("Verdana", 10, FontStyle.Bold), Brushes.Black, 30, 30)
For Each dr As DataGridViewRow In dg.Rows
e.Graphics.DrawString(dr.Cells(0).Value & " | " & dr.Cells(2).Value &
" | " & dr.Cells(3).Value & " | " & dr.Cells(4).Value & " | " &
dr.Cells(6).Value & " | " & dr.Cells(7).Value & " | " &
dr.Cells(9).Value & " | " & dr.Cells(11).Value & " | " &
dr.Cells(12).Value, New Font("Verdana", 10), Brushes.Black, 30, y)
y += 20
Next
End Sub
End Class
Add to Form(Design) Button1, PrintDocument1 ,PrintPreviewDialog1 , your -> DataGridView1
and paste the code:
Dim mRow As Integer = 0
Dim newpage As Boolean = True
Private Sub PrintDocument1_PrintPage(sender As System.Object, e As System.Drawing.Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage
With DataGridView1
Dim fmt As StringFormat = New StringFormat(StringFormatFlags.LineLimit)
fmt.LineAlignment = StringAlignment.Center
fmt.Trimming = StringTrimming.EllipsisCharacter
Dim y As Single = e.MarginBounds.Top
Do While mRow < .RowCount
Dim row As DataGridViewRow = .Rows(mRow)
Dim x As Single = e.MarginBounds.Left
Dim h As Single = 0
For Each cell As DataGridViewCell In row.Cells
Dim rc As RectangleF = New RectangleF(x, y, cell.Size.Width, cell.Size.Height)
e.Graphics.DrawRectangle(Pens.Black, rc.Left, rc.Top, rc.Width, rc.Height)
If (newpage) Then
e.Graphics.DrawString(DataGridView1.Columns(cell.ColumnIndex).HeaderText, .Font, Brushes.Black, rc, fmt)
Else
e.Graphics.DrawString(DataGridView1.Rows(cell.RowIndex).Cells(cell.ColumnIndex).FormattedValue.ToString(), .Font, Brushes.Black, rc, fmt)
End If
x += rc.Width
h = Math.Max(h, rc.Height)
Next
newpage = False
y += h
mRow += 1
If y + h > e.MarginBounds.Bottom Then
e.HasMorePages = True
mRow -= 1
newpage = True
Exit Sub
End If
Loop
mRow = 0
End With
End Sub
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button3.Click
PrintPreviewDialog1.Document = PrintDocument1
PrintPreviewDialog1.ShowDialog()
End Sub
For pecific Columns (example column 1,3,4)
Private Sub PrintDocument1_PrintPage(sender As System.Object, e As System.Drawing.Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage
Dim custCells As Integer() = {1, 3, 4}
With DataGridView1
Dim fmt As StringFormat = New StringFormat(StringFormatFlags.LineLimit)
fmt.LineAlignment = StringAlignment.Center
fmt.Trimming = StringTrimming.EllipsisCharacter
Dim y As Single = e.MarginBounds.Top
Do While mRow < .RowCount
Dim row As DataGridViewRow = .Rows(mRow)
Dim x As Single = e.MarginBounds.Left
Dim h As Single = 0
For Each cell As Integer In custCells
Dim rc As RectangleF = New RectangleF(x, y, row.Cells(cell).Size.Width, row.Cells(cell).Size.Height)
e.Graphics.DrawRectangle(Pens.Black, rc.Left, rc.Top, rc.Width, rc.Height)
If (newpage) Then
e.Graphics.DrawString(DataGridView1.Columns(cell).HeaderText, .Font, Brushes.Black, rc, fmt)
Else
e.Graphics.DrawString(DataGridView1.Rows(row.Cells(cell).RowIndex).Cells(cell).FormattedValue.ToString(), .Font, Brushes.Black, rc, fmt)
End If
x += rc.Width
h = Math.Max(h, rc.Height)
Next
newpage = False
y += h
mRow += 1
If y + h > e.MarginBounds.Bottom Then
e.HasMorePages = True
mRow -= 1
newpage = True
Exit Sub
End If
Loop
mRow = 0
End With
End Sub
You may find that moving the data to Excel/Word would be as useful:
Private Sub tsbtnCopy_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles tsbtnCopy.Click
dgv01.SuspendLayout()
dgv01.RowHeadersVisible = False
If dgv01.SelectedRows.Count = 0 Then dgv01.SelectAll()
Clipboard.SetDataObject(dgv01.GetClipboardContent())
dgv01.ClearSelection()
dgv01.RowHeadersVisible = True
dgv01.ResumeLayout()
End Sub
Or have the user select all (click upper left cell) to copy/Paste.
I found a solution to fix the disappearing header problem. The thing is that the PrintDocument is called 2 times, once for preview, the second time just before printing. Exactly before printing it is necessary to reset the variables mRow = 0 and newpage = True again.
I used hijacking the print button, which I replaced with my. I added this code to the PRINT button on my form.
b.Image = CType(PrintDialog.Controls(1), ToolStrip).ImageList.Images(0)
b.ToolTipText = "Print"
b.DisplayStyle = ToolStripItemDisplayStyle.Image
AddHandler b.Click, AddressOf PrintPreview_PrintClick
CType(PrintDialog.Controls(1), ToolStrip).Items.RemoveAt(0)
CType(PrintDialog.Controls(1), ToolStrip).Items.Insert(0, b)
As a result, the following code is placed in the newly added button
Private Sub PrintPreview_PrintClick(sender As Object, e As EventArgs)
Try
mRow = 0
newpage = True
PrintDocument.Print()
Catch ex As Exception
End Try
End Sub

all possible combinations

i need to get a list of all possible combinations, not permutations.
to make sure i have the right name, 123 and 321 to me are the same thing and should only be listed once.
the code below does what i need but i can't convert it into MS Access vba.
i'm sorry, i know this is basic and it has been asked a million times but i can't find anything for MS Access that works for me.
Sub test_print_nCr()
print_nCr 7, 3, Range("A1")
End Sub
2.
Public Function print_nCr(n As Integer, r As Integer, p As Range)
c = 1
internal_print_nCr n, r, p, 1, 1
End Function
3.
Public Function internal_print_nCr(n As Integer, r As Integer, ByVal p As Range, Optional i As Integer, Optional l As Integer) As Integer
' n is the number of items we are choosing from
' r is the number of items to choose
' p is the upper corner of the output range
' i is the minimum item we are allowed to pick
' l is how many levels we are in to the choosing
' c is the complete set we are working on
If n < 1 Or r > n Or r < 0 Then Err.Raise 1
If i < 1 Then i = 1
If l < 1 Then l = 1
If c < 1 Then c = 1
If r = 0 Then
p = 1
Exit Function
End If
Dim x As Integer
Dim y As Integer
For x = i To n - r + 1
If r = 1 Then
If c > 1 Then
For y = 0 To l - 2
If p.Offset(c - 1, y) = "" Then p.Offset(c - 1, y) = p.Offset(c - 2, y)
Next
End If
p.Offset(c - 1, l - 1) = x
c = c + 1
Else
p.Offset(c - 1, l - 1) = x
internal_print_nCr n, r - 1, p, x + 1, l + 1
End If
Next
End Function
thank you again
I am not sure if this is the best method to do this, but I would use a kind of binary representation. For instance, consider the word "boy" with the number of letters n=3. This word has three letters, so you can use something like this:
001 = y,
010 = o,
011 = oy,
100 = b,
101 = by,
110 = bo,
111 = boy.
The left side can be done with a loop from i=1 to power(2,n)-1 and transforming i to a number in the binary basis. So, the only thing you have to do is to use the non null positions to build your combinations.
Probably there is something more interesting than this in Knuth.
i found this code here, and it gives me exactly what i need. you just have to create a table with numbers from 1-100. instructions at the link below
enter link description here
thank you everyone
Public Sub buildquery(strN As String, K As Integer)
Dim qd As DAO.QueryDef
Dim intI As Integer
Dim strsql As String
Dim strSelect As String
Dim strFrom As String
Dim strWhere As String
Set qd = CurrentDb.QueryDefs("QN")
qd.sql = "SELECT N FROM tblN WHERE N IN (" & strN & ")"
Set qd = Nothing
strSelect = "SELECT QN.N "
strFrom = "FROM QN "
strWhere = "WHERE QN_1.N > QN.N "
For intI = 1 To K - 1
strSelect = strSelect & ", QN_" & intI & ".N AS N" & intI & " "
strFrom = strFrom & ", QN AS QN_" & intI & " "
If intI < K - 1 Then
strWhere = strWhere & " AND QN_" & intI + 1 & ".N > QN_" & intI & ".N "
End If
Next
strsql = strSelect & " INTO tblCombinations " & strFrom & strWhere
DoCmd.SetWarnings False
DoCmd.RunSQL strsql
DoCmd.SetWarnings True
End Sub
then test
Public Sub testbuildquery()
buildquery "1,2,3,4,5,6,7", 3
End Sub