I am doing project in vb.net which is already done in vb6
I am having text box .I want to apply font (style,color,name,size) to selected text.
I am able to do this ..& want to create bitmap of this textbox text so that i can create matrix of 0,1,2,3 digits if text color is red then 1 digit,green-2,orange-3
Following code is done in vb6 but i am not getting some properties in vb.net like
picture1.point
picture1.print (here picture1 is picture box)
here Led is array of (digits 0 or 1 or 2 or 3 )
converttodis is functiont that converts each letter into array
Code is here
Private Sub CmdPreview_Click()
On Error Resume Next
Dim i
Picture1.Cls
lRow = 0
Lcol = 0
ReDim Led(Picture1.TextHeight(TxtMsg.Text), Picture1.TextWidth(TxtMsg.Text))
For i = 1 To Len(TxtMsg.Text)
TxtMsg.SelStart = i - 1
TxtMsg.SelLength = 1
Picture1.Font = TxtMsg.SelFontName
Picture1.FontSize = TxtMsg.SelFontSize
Picture1.FontBold = TxtMsg.SelBold
Picture1.FontItalic = TxtMsg.SelItalic
If Mid(TxtMsg.Text, i, 1) <> vbCr Then
Picture1.Print Mid(TxtMsg.Text, i, 1)
ConvertToDis i, TxtMsg.selcolor
ElseIf Mid(TxtMsg.Text, i, 2) = vbCrLf Then
i = i + 1
lRow = lRow + Picture1.TextHeight(Mid(TxtMsg.Text, i - 2, 1))
Lcol = 0
Else
Picture1.Print Mid(TxtMsg.Text, i, 1)
ConvertToDis i, TxtMsg.selcolor
End If
Next
End Sub
Public Function ConvertToDis(ByVal i As Long, ByVal col)
Dim CX, CY, f, f1, F2
Dim lsubrow, Lsubcol As Integer
lsubrow = lRow
Lsubcol = Lcol
For CY = 0 To Picture1.TextHeight(Mid(TxtMsg.Text, i, 1))
For CX = 0 To Picture1.TextWidth(Mid(TxtMsg.Text, i, 1))
If Picture1.Point(CX, CY) < vbWhite - 4300000 Then
If col = 255 Then
LedCol(lsubrow, Lsubcol) = 1
ElseIf col = 65280 Then
LedCol(lsubrow, Lsubcol) = 2
ElseIf col = 33023 Then
LedCol(lsubrow, Lsubcol) = 3
Else
LedCol(lsubrow, Lsubcol) = 0
End If
DoEvents
Lsubcol = Lsubcol + 1
Next
lsubrow = lsubrow + 1
Lsubcol = Lcol
Next
Picture1.Cls
Lcol = Lcol + Picture1.TextWidth(Mid(TxtMsg.Text, i, 1))
End Function
for LONG word output is like this
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000011111000000011111100001111101111000111110000000000
000001110000001111111110000111100111001111111100000000
000001110000001111000110000111100110011110001110000000
000001110000011111000011000111100110111110001000000000
000001110000011010000011000111100110110110000000000000
000001110000011010000011000111110110110111111110000000
000001110000011010000011000110110110110110001111000000
000001110000011010000011000110111110110111111110000000
000001110000011110000011000110011110111100001110000000
000001110000101110000111000110011110011100001110000000
000001110011100111001110000110001110011110001110000000
000011111111110011111100001111001110000111111110000000
000011111111110011111000011111001110000111111111000000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000111111111111111111111111111111111111111111111110000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000
From Graphics for Visual Basic 6.0 Users:
In Visual Basic 2008, the Point method no longer exists. You can use the System.Drawing.Bitmap.GetPixel(System.Int32,System.Int32) method to retrieve a color value from a bitmap. For forms or controls that do not contain a picture, you can query the BackColor property.
In Visual Basic 2008, the DrawString method is used to display text. The font is determined by a Font object, and the color is determined by a Brush object; both are passed as parameters to the DrawString method. The DrawString method also has X and Y parameters that determine the starting location for the text. There is also an optional Format parameter that takes a StringFormat object, allowing you to display text vertically.
Related
If I want to create a random order to select another pair from my image. , not repeating the random pair i've previously picked, i.e. so that once i've gone through 56 random unique images i.e. 26 random pairs, the game is over, and reset to my original 57 images and start picking random pairs again. Can this be done in VBA Powerpoint?
This is the sub I am using:
Sub RandomImage()
Dim i As Long
Dim posLeft As Long
For i = 1 To 2
Randomize
RanNum% = Int(57 * Rnd) + 1
Path$ = ActivePresentation.Path
FullFileName$ = Path$ + "/" + CStr(RanNum%) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(FileName:=FullFileName$, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=posLeft, Top:=100, Width:=400)
Next
End Sub
Please, try the next function. It uses an array built from 1 to maximum necessary/existing number. It returns the RND array element and then eliminate it from the array, next time returning from the remained elements:
Please, copy the next variables on top of the module keeping the code you use (in the declarations area):
Private arrNo
Private Const maxNo As Long = 57 'maximum number of existing pictures
Copy the next function code in the same module:
Function ReturnUniqueRndNo() As Long
Dim rndNo As Long, filt As String, arr1Based, i As Long
If Not IsArray(arrNo) Then
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
End If
If UBound(arrNo) = 0 Then
ReturnUniqueRndNo = arrNo(0)
ReDim arrNo(maxNo - 1)
For i = 0 To UBound(arrNo): arrNo(i) = i + 1: Next i
MsgBox "Reset the used array..."
Exit Function
End If
Randomize
rndNo = Int((UBound(arrNo) - LBound(arrNo) + 1) * Rnd + LBound(arrNo))
ReturnUniqueRndNo = arrNo(rndNo) 'return the array element
filt = arrNo(rndNo) & "$$$": arrNo(rndNo) = filt 'transform the array elem to be removed
arrNo = filter(arrNo, filt, False) 'eliminate the consumed number, but returning a 0 based array...
End Function
The used array is reset when reaches its limit and send a message.
It may be tested using the next testing Sub:
Sub testReturnUniqueRndNo()
Dim uniqueNo As Long, i As Long
For i = 1 To 2
uniqueNo = ReturnUniqueRndNo
Debug.Print uniqueNo
Next i
End Sub
In order to test it faster, you may modify maxNo at 20...
After testing it, you have to modify your code in the next way:
Sub RandomImage()
Dim i As Long, posLeft As Long, RanNum%, path$, fullFileName$
path = ActivePresentation.path
For i = 1 To 2
RanNum = ReturnUniqueRndNo
fullFileName = path + "/" + CStr(RanNum) + ".png"
posLeft = 50 + ((i - 1) * 400)
Call ActivePresentation.Slides(1).Shapes.AddPicture(fileName:=fullFileName, _
LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, left:=posLeft, top:=100, width:=400)
Next
End Sub
Please, test it and send some feedback. I did not test it in Access, but it should work...
I have a 16*16 matrix and I'm trying to define them as a matrix series in vb.net. Then i make some visual shows with this matrix like led shows.
Dim n As Integer = 16
Dim l As Integer = 16
Dim x(n - 1, l - 1) As Integer
Dim i, j, k As Integer
For i = 0 To n - 1
For j = 0 To l - 1
For k = 1 To 256
If j= k mod16 then
buton(k) = x(i, j)
end if
Next
Next
Next***
I try to apply an algorithm. But it doesn't work. How can i accomplish this? Thanks for your interests..
OK I wrote something like this a while ago - I've adapted it to your needs and it runs ok on my pc. You need to create you array X like this
Dim x(15,15) As Button
To fill the array with buttons, use this method..
Private Sub InitializeArray()
Dim btnslist As New List(Of Button)
Dim btnNum As Integer
Dim btnName As String
Dim splitButtonName() As String
'add all the buttons to a list
For Each btnControl As Object In Controls
Dim btn As Button
'get button number and add it to the list if it is >0 and <=256
If TypeOf btnControl Is Button Then
btn = CType(btnControl, Button)
'get the button number
splitButtonName = Split(btn.Name, "n")
If CInt(splitButtonName(1)) > 0 And CInt(splitButtonName(1)) <= 256 Then
btnslist.Add(btn)
End If
End If
Next
'add the buttons to the matrix in the right order
For i As Integer = 0 To 15
For j As Integer = 0 To 15
For k As Integer = 0 To 255
btnNum = i * 16 + j + 1
btnName = "Button" & btnNum.ToString
If btnslist(k).Name = btnName Then
x(i, j) = btnslist(k)
Exit For
End If
Next
Next
Next
End Sub
I'm currently working on a project where I'll be selecting up to 5 items to compare to each other, with the results being displayed in up to a 5x5 dynamic grid. My objective is to have this grid be composed of command buttons such that the caption of each button is the percent similarity between the row and column items, and on clicking the button, the units that are common between the row and column items will be displayed in a message box.
I more or less know how to generate the actual array of buttons. However, everything I've read suggests that I need to create a class to handle the button clicks, since I don't feel like making 20 subroutines that all have the same code in them. I have not been able to get this class to work properly, and I could use some tips. Here's what I have so far.
In a class module named DynButton:
Public Withevents CBevents as MSForms.CommandButton
Private Sub CBevents_Click()
DisplayOverlappedUnits 'Sub that will display the units that are the same
'between items i and j- may use Application.Caller
End Sub
And in the userform itself:
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton
Dim ctlButton as MSForms.CommandButton
'QuestionList() is a public type that stores various attributes of the
'items I'm comparing.
'This code determines how many items were selected for comparison
'and resets the item array accordingly.
NumItems=0
For i=1 to 5
If QuestionList(i).Length>0 Then
NumItems=Numitems+1
QuestionList(NumItems)=QuestionList(i)
End If
Next
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j=1 to NumItems
Set ctlButton=Me.Controls.Add("Forms.CommandButton.1", Cstr(i) & Cstr(j) & cb)
With ctlButton
.Height= CB_HEIGHT 'These are public constants defined elsewhere.
.Width= CB_WIDTH
.Top= TOP_OFFSET + (i * (CB_HEIGHT+ V_PADDING))
If i = j Then .visible = False
.Caption= CalculateOverlap(i,j) 'Runs a sub that calculates the overlap between items i and j
End With
Set ComparisonArray(i,j).CBevents = ctlButton
Next
Next
End Sub
Currently, I get a "Object with or Block variable not set" when I hit the Set ComparisonArray line, and I'm stymied. Am I just missing something in the class module? Thanks in advance for the help.
Edited to add: I tried to model the class code in part off of this article, but again I haven't got it to work yet. http://www.siddharthrout.com/index.php/2018/01/15/vba-control-arrays/
Private Sub Userform_Initialize()
Dim NumItems as integer
Dim ComparisonArray() as DynButton '<<<< should be a Global variable
As soon as Userform_Initialize completes, ComparisonArray() will go out of scope and no longer exist: you need to make that a Global variable in your form so it will be around to handle any events.
Your code seems correct and interesting. The only (bug) I could see is:
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
...
Set ComparisonArray(i,j).CBevents = ctlButton
The problem is that your array holds null references. You have not created your DynButton objects yet. You must explicitly creat the objects in your array.
Redim ComparisonArray(1 to NumItems, 1 to NumItems)
For i = 1 to NumItems
For j = 1 to NumItems
Set ComparisonArray(i,j) = new DynButton
Next
Next
...
Set ComparisonArray(i,j).CBevents = ctlButton
Also, declare the array ComparisonArray as a member object of the form, not as a local variable in Form_Initialize.
Only copy paste
Option Private Module
Option Explicit
Private Const i_total_channels As Integer = 100
Sub createArrayOfbuttons()
Application.ScreenUpdating = False
f_create_buttons 5, 5, 30, 5, True
End Sub
Sub clearArrayOfButtos()
Application.ScreenUpdating = False
f_clear_array_of_buttons
End Sub
Private Function f_create_buttons(Optional posLeft As Integer = 0, Optional posTop As Integer = 0, _
Optional sizeSquare As Integer = 20, Optional distBetween As Integer, Optional buttonColor As Boolean = False)
'create customized buttons to channel choice.
Dim i_ch_amount_x As Integer
Dim i_ch_amount_y As Integer
Dim i_size_X 'size of square button
Dim i_size_Y 'size of square button
Dim i_stp_X As Integer 'step in X
Dim i_stp_Y As Integer 'step in Y
Dim i_dist_bte_buttons As Integer 'distance between buttons, in X and Y
Dim i_pos_ini_X As Integer 'initial position
Dim i_pos_ini_Y As Integer
Dim it_x As Integer 'iterator
Dim it_y As Integer 'iterator
Dim amount As Integer 'channel acumulator
Dim FO_color As Integer 'index from 1 to 12 to change background color of button
f_clear_array_of_buttons
i_pos_ini_X = posLeft
i_pos_ini_Y = posTop
'create dimensions of square
i_size_X = sizeSquare
i_size_Y = i_size_X 'to create a square Y need same size of X
'distance between squares
i_dist_bte_buttons = i_size_X + distBetween 'to shift distance change laste value of expression
i_stp_X = i_pos_ini_X
i_stp_Y = i_pos_ini_Y
i_ch_amount_x = Int(Sqr(i_total_channels)) 'total channels in switch (i_ch_amount_y * i_ch_amount_x)
i_ch_amount_y = i_ch_amount_x
amount = 1
FO_color = 1
For it_y = 1 To i_ch_amount_x
For it_x = 1 To i_ch_amount_y
f_create_button amount, i_stp_X, i_stp_Y, CSng(i_size_X), CSng(i_size_Y), FO_color
i_stp_X = i_stp_X + i_dist_bte_buttons
amount = amount + 1
If buttonColor Then
FO_color = FO_color + 1
End If
If FO_color > 12 Then 'return FO to 1
FO_color = 1
End If
Next it_x
i_stp_X = i_pos_ini_X
i_stp_Y = i_stp_Y + i_dist_bte_buttons
Next it_y
amount = 0
i_ch_amount_x = 0
i_ch_amount_y = 0
i_size_X = 0
i_size_Y = 0
i_stp_X = 0
i_stp_Y = 0
i_pos_ini_X = 0
i_pos_ini_Y = 0
i_dist_bte_buttons = 0
FO_color = 0
End Function
Private Function f_create_button(index As Integer, posLeft As Integer, posRight As Integer, _
Box_width As Single, Box_height As Single, Optional FO As Integer)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, posLeft, posRight, Box_width, Box_height). _
Select
With Selection
.Name = "ch_" & index
.Text = index
.Font.Name = "Arial"
.Font.Bold = True
If FO = 9 Then
.Font.Color = vbWhite
Else
.Font.ColorIndex = xlAutomatic
End If
.Font.Size = 10
.Interior.Color = fiber_color(FO)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Function
Public Function fiber_color(Optional FO As Integer = 1) As Long
'use with a index in FO from 1 to 12
Select Case FO
Case 1
fiber_color = 65280 'green
Case 2
fiber_color = 65535 'yellow
Case 3
fiber_color = 16777215 'white
Case 4
fiber_color = 16711680 'blue
Case 5
fiber_color = 255 'red
Case 6
fiber_color = 16711823 'violt
Case 7
fiber_color = 19350 'brown
Case 8
fiber_color = 13353215 'pink
Case 9
fiber_color = 0 'black
Case 10
fiber_color = 16711680 'cinza
Case 11
fiber_color = 32767 'orange
Case 12
fiber_color = 16776960 'aqua
Case Else
fiber_color = 65280 'verde
End Select
End Function
Private Function f_clear_array_of_buttons()
Dim i_ch_amount_x As Integer
Dim it As Integer
i_ch_amount_x = i_total_channels
On Error GoTo sair
If ActiveSheet.Shapes.Count <> 0 Then
For it = 1 To i_ch_amount_x
ActiveSheet.Shapes("ch_" & it).Delete
Next it
End If
sair:
i_ch_amount_x = 0
it = 0
End Function
Right, so using Python I would create a multidimensional list and set the values on one line of code (as per the below).
aryTitle = [["Desciption", "Value"],["Description2", "Value2"]]
print(aryTitle[0,0] + aryTitle[0,1])
I like the way I can set the values on one line. In VBA I am doing this by:
Dim aryTitle(0 To 1, 0 To 1) As String
aryTitle(0, 0) = "Description"
aryTitle(0, 1) = "Value"
aryTitle(1, 0) = "Description2"
aryTitle(1, 1) = "Value2"
MsgBox (aryTitle(0, 0) & aryTitle(0, 1))
Is there a way to set the values in one line of code?
Not natively, no. But you can write a function for it. The only reason Python can do that is someone wrote a function to do it. The difference is that they had access to the source so they could make the syntax whatever they like. You'll be limited to VBA function syntax. Here's a function to create a 2-dim array. It's not technically 'one line of code', but throw it in your MUtilities module and forget about it and it will feel like one line of code.
Public Function FillTwoDim(ParamArray KeyValue() As Variant) As Variant
Dim aReturn() As Variant
Dim i As Long
Dim lCnt As Long
ReDim aReturn(0 To ((UBound(KeyValue) + 1) \ 2) - 1, 0 To 1)
For i = LBound(KeyValue) To UBound(KeyValue) Step 2
If i + 1 <= UBound(KeyValue) Then
aReturn(lCnt, 0) = KeyValue(i)
aReturn(lCnt, 1) = KeyValue(i + 1)
lCnt = lCnt + 1
End If
Next i
FillTwoDim = aReturn
End Function
Sub test()
Dim vaArr As Variant
Dim i As Long
Dim j As Long
vaArr = FillTwoDim("Description", "Value", "Description2", "Value2")
For i = LBound(vaArr, 1) To UBound(vaArr, 1)
For j = LBound(vaArr, 2) To UBound(vaArr, 2)
Debug.Print i, j, vaArr(i, j)
Next j
Next i
End Sub
If you supply an odd number of arguments, it ignores the last one. If you use 3-dim arrays, you could write a function for that. You could also write a fancy function that could handle any dims, but I'm not sure it's worth it. And if you're using more than 3-dim arrays, you probably don't need my help writing a function.
The output from the above
0 0 Description
0 1 Value
1 0 Description2
1 1 Value2
You can write a helper function:
Function MultiSplit(s As String, Optional delim1 As String = ",", Optional delim2 As String = ";") As Variant
Dim V As Variant, W As Variant, A As Variant
Dim i As Long, j As Long, m As Long, n As Long
V = Split(s, delim2)
m = UBound(V)
n = UBound(Split(V(0), delim1))
ReDim A(0 To m, 0 To n)
For i = 0 To m
For j = 0 To n
W = Split(V(i), delim1)
A(i, j) = Trim(W(j))
Next j
Next i
MultiSplit = A
End Function
Used like this:
Sub test()
Dim A As Variant
A = MultiSplit("Desciption, Value; Description2, Value2")
Range("A1:B2").Value = A
End Sub
I created some kind of phone protocol sheet in excel and I wanted to add a section with quadrille paper for sketching purposes. Therefore I wrote a quite simple macro in VBA that draws horizontal and vertical lines in a selected range:
Public Sub Fill()
Dim angepeilteMaschenWeiteInPixel As Integer
angepeilteMaschenWeiteInPixel = 15
Dim LinienFarbe As Long
LinienFarbe = RGB(220, 220, 220)
Dim obenLinks As Double, obenRechts As Double
Dim untenLinks As Double, untenRechts As Double
Dim ausgewaehlteRange As Range
Set ausgewaehlteRange = Selection
' Anzahl Spalten und Zeilen ermitteln bei idealer Breite/Höhe 10px
Dim idealeSpaltenAnzahl As Integer
Dim idealeZeilenAnzahl As Integer
idealeSpaltenAnzahl = CInt(Round((ausgewaehlteRange.Width / angepeilteMaschenWeiteInPixel), 0))
idealeZeilenAnzahl = CInt(Round((ausgewaehlteRange.Height / angepeilteMaschenWeiteInPixel), 0))
' Aus der idealen Spalten- und Zeilenanzahl die ideale Maschenweite und - höhe in Pixeln ermitteln
Dim idealeMaschenBreite As Double
Dim idealeMaschenHoehe As Double
idealeMaschenBreite = ausgewaehlteRange.Width / CDbl(idealeSpaltenAnzahl)
idealeMaschenHoehe = ausgewaehlteRange.Height / CDbl(idealeZeilenAnzahl)
' vertikale Linien zeichnen
Dim i As Integer
For i = 1 To idealeSpaltenAnzahl - 1
Dim horizontal As Integer
horizontal = CInt(ausgewaehlteRange.Left + i * idealeMaschenBreite)
Dim oben As Integer
oben = Round(ausgewaehlteRange.Top, 0)
Dim unten As Integer
unten = Round(oben + ausgewaehlteRange.Height, 0)
With ActiveSheet.Shapes.AddLine(horizontal, oben, horizontal, unten).Line
.ForeColor.RGB = LinienFarbe
End With
Next i
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal).Line
.ForeColor.RGB = LinienFarbe
End With
Next j
End Sub
in excel everything looks fine:
but in the print preview and also printed out, the horizontal line gap is uneven and I have no idea why:
Anybody out there who can help me?
I suspect the lines are moving with the cells. Try setting the object positioning property to "Don't move or size with cells" which the English value is xlFreeFloating.
Example:
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
End With
Edit
Interesting behavior... I still think it's related to cells & margins as the lines move with cell width changes in print preview even though position is set to freeform.
I did find a workaround by grouping the lines together.
Added three lines of code. Add the following to both With blocks after Horizontal and Vertical lines are created.
.Select Replace:=False
Now add this line at the end of the sub:
Selection.Group
Now all the lines that were just created are grouped together.
Result image from print preview.
Example of last code block for your reference:
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
.Select Replace:=False
End With
Next j
Selection.Group
End Sub