Vertical Text on Button control VB - vb.net

One of my buttons on a form needs to show vertical text like that:
S
T
O
P
I found solutions involving overriding Paint that seems too complicated for such a simple task. I tried this:
Private Sub LabelStopButton()
Dim btTitle As String = "S" & vbCrLf & "T" & vbCrLf & "O" & vbCrLf & "P" & vbCrLf
Me.btnStop.Text = btTitle
End Sub
and also tried replacing vbCrLf with: vbCr, vbLf, Environment.NewLine - to no avail, same result: only the first letter "S" is showing on the button. See image.
Using Visual Studio 2008 (this is an app for an old WinCE 6.0 device).
Any advice?
Thanks!

This is a duplcate of an existing question
See https://stackoverflow.com/a/7661057/2319909
Converted code for reference:
You need to set the button to allow multiple lines. This can be achieved with following P/Invoke code.
Private Const BS_MULTILINE As Integer = &H2000
Private Const GWL_STYLE As Integer = -16
<System.Runtime.InteropServices.DllImport("coredll")> _
Private Shared Function GetWindowLong(hWnd As IntPtr, nIndex As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("coredll")> _
Private Shared Function SetWindowLong(hWnd As IntPtr, nIndex As Integer, dwNewLong As Integer) As Integer
End Function
Public Shared Sub MakeButtonMultiline(b As Button)
Dim hwnd As IntPtr = b.Handle
Dim currentStyle As Integer = GetWindowLong(hwnd, GWL_STYLE)
Dim newStyle As Integer = SetWindowLong(hwnd, GWL_STYLE, currentStyle Or BS_MULTILINE)
End Sub
Use it like this:
MakeButtonMultiline(button1)

I created vertical text on the button with the following codes :
CommandButton1.Caption = "F" & Chr(10) & "I" & Chr(10) & "L" & Chr(10) & "T" & Chr(10) & "E" & Chr(10) & "R" & Chr(10)
Source of userform

Related

Apply working Shell code in a different database

I have used the "Shell" function, in other Access databases, to open folders.
With the same code structure I get the
5 error code of "Invalid procedure call or argument"
Using shell function as follows:
Dim FreightFile_Path As String
FreightFile_Path = "S:\Supply Chain\Freight"
Shell "explorer.exe" & " " & FreightFile_Path, vbNormalFocus
I tried the double quotes and Chr(34)'s around them.
I copied the code from one database (that it worked in) to another and it error-ed.
Am I missing something I need to activate in MS Access? I checked the references in VBA and made sure they match.
Things I tried:
Call Shell("explorer.exe" & " " & Chr(34) & "S:\Shared" & Chr(34),
vbNormalFocus)
Shell "explorer.exe " & Chr(34) & FreightFile_Path & Chr(34), vbNormalFocus
Shell "explorer.exe" & " " & FreightFile_Path, vbNormalFocus
Dim retVal
retVal = Shell("explorer.exe" & " " & FreightFile_Path, vbNormalNoFocus)
Dim i As String
i = "explorer.exe" & " " & FreightFile_Path
Shell i, vbNormalFocus
FreightFile_Path = "S:\Supply Chain\Freight"
Shell "explorer.exe " & FreightFile_Path, vbNormalFocus
Restarted the application, restarted the computer.
I just had the same problem. In my case, it turned out to be anti-virus that was blocking Shell. It just so happened that IT had put exceptions in place for my computer for one database but not the other. See my question and answer for more detail.
Try this:
FreightFile_Path = "S:\Supply Chain\Freight"
Shell "cmd /c start explorer.exe """ & FreightFile_Path & """"
It is a bit of a workaround, but it works...
New try. Use a WinAPI call
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal lpnShowCmd As Long) As Long
Public Sub ShellEx(ByVal Path As String, Optional ByVal Parameters As String, Optional ByVal HideWindow As Boolean)
If Dir(Path) > "" Then
ShellExecute 0, "open", Path, Parameters, "", IIf(HideWindow, 0, 1)
End If
End Sub
Sub Test()
FreightFile_Path = "S:\Supply Chain\Freight"
ShellEx "c:\windows\explorer.exe", """" & FreightFile_Path & """"
End Sub
Thank you everybody for the help. This might not really be an answer to the Shell problem, but it will work for opening a file path.
Dim FreightFilePath As String
FreightFilePath = "S:\Supply Chain\Freight"
Application.FollowHyperLink FreightFilePath

Clickable Chart in excel

I want to create a pie chart with linked sheet but when I am clicking on the graph I am getting some error, "Compile error Argument not optional" on the "WorkSheetFunction.Index" line of the code.
I am beginner in VBA coding.. Please help
this is my code
xl page
ThisWorkbook module
Dim ChartObjectClass As New Class1
Dim ChartObjectClass2 As New Class2
Private Sub Workbook_Open()
Set ChartObjectClass.ChartObject = Worksheets(1).ChartObjects(1).Chart
Set ChartObjectClass2.ChartObject = Worksheets(1).ChartObjects(2).Chart
End Sub
Class module
Option Explicit
Public WithEvents ChartObject As Chart
Private Sub ChartObject_MouseUp(ByVal Button As Long, ByVal Shift As Long, _
ByVal x As Long, ByVal y As Long)
Dim ElementID As Long, Arg1 As Long, Arg2 As Long
Dim myX As Variant, myY As Double
With ActiveChart
.GetChartElement x, y, ElementID, Arg1, Arg2
If ElementID = xlSeries Or ElementID = xlDataLabel Then
If Arg2 > 0 Then
myX=WorksheetFunction.Index(.SeriesCollection(Arg1).XValues.Arg2)
myY=WorksheetFunction.Index(.SeriesCollection(Arg1).Values.Arg2)
MsgBox "Series" & Arg1 & vbCrLf & """" & .SeriesCollection(Arg1)_
.Name & """" & vbCrLf & "Point" & Arg2 & vbCrLf & _
"x= " & myX & vbCrLf & "y= " & myY
Range("A1").Select
On Error Resume Next
Sheets("Series" & myX & "Detail").Select
Range("A1").Select
On Error GoTo 0
End If
End If
End With
End Sub
In your case, Index requires two arguments. The first argument specifies the array of values from which to return a value. The second argument specifies the nth element from the array to return.
myX = WorksheetFunction.Index(.SeriesCollection(Arg1).XValues, Arg2)
myY = WorksheetFunction.Index(.SeriesCollection(Arg1).Values, Arg2)
By the way, you can also dispense with the use of WorksheetFunction.Index...
myX = .SeriesCollection(Arg1).XValues()(Arg2)
myY = .SeriesCollection(Arg1).Values()(Arg2)

Send Raw Data to ZPL Printer using Visual Basic (MS Access 2000)

This is all that I can find, none of them work.
Option Compare Database
Option Explicit
Private Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
ByVal pDefault As Long) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias _
"StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pDocInfo As DOCINFO) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" (ByVal _
hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, _
pcWritten As Long) As Long
Private Sub TEST()
Dim lhPrinter As Long
Dim lReturn As Long
Dim lpcWritten As Long
Dim lDoc As Long
Dim sWrittenData As String
Dim MyDocInfo As DOCINFO
lReturn = OpenPrinter("ZDesigner LP 2844", lhPrinter, 0)
If lReturn = 0 Then
MsgBox "The Printer Name you typed wasn't recognized."
Exit Sub
End If
MyDocInfo.pDocName = "AAAAAA"
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
Call StartPagePrinter(lhPrinter)
sWrittenData = "N" & vbFormFeed
sWrittenData = sWrittenData & "q609" & vbFormFeed
sWrittenData = sWrittenData & "Q203,26" & vbFormFeed
sWrittenData = sWrittenData & "B26,26,0,UA0,2,2,152,B," & Chr(34) & "603679025109" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,26,0,3,1,1,N," & Chr(34) & "SKU 6205518 MFG 6354" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,56,0,3,1,1,N," & Chr(34) & "2XIST TROPICAL BEACH" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,86,0,3,1,1,N," & Chr(34) & "STRIPE SQUARE CUT TRUNK" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,116,0,3,1,1,N," & Chr(34) & "BRICK" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "A253,146,0,3,1,1,N," & Chr(34) & "X-LARGE" & Chr(34) & vbFormFeed
sWrittenData = sWrittenData & "P1,1" & vbFormFeed
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), lpcWritten)
lReturn = EndPagePrinter(lhPrinter)
lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
End Sub
Method 2
Option Compare Database
Private Sub crtLabel()
Dim prtDevice As String
Dim strQuote As String
strQuote = Chr(34)
prtDevice = "ZDesigner LP 2844" ' whatever device Access currently has as the default. I have the user select a printer prior to printing, which sets the Access defaut printer
' open printer port
Open prtDevice For Output As #1
' initialize printer
Print #1, "OD" & vbCrLf
Print #1, "N" & vbCrLf
Print #1, "O" & vbCrLf
Print #1, "Q545,B12+23" & vbCrLf
Print #1, "q262" & vbCrLf
Print #1, "UN" & vbCrLf
Print #1, "rN" & vbCrLf
Print #1, "N" & vbCrLf
Print #1, "A4,94,3,3,1,1,N," & strQuote & "1803" & strQuote & vbCrLf
Print #1, "A36,74,3,3,1,1,N," & strQuote & "B" & strQuote & vbCrLf
Print #1, "A64,94,3,3,1,1,N," & strQuote & "079" & strQuote & vbCrLf
Print #1, "A112,8,0,2,1,1,N," & strQuote & strQuote & vbCrLf ' you can replace any string like "1803" with a string variable like SID or AID that gets passed to the sub
Print #1, "A112,32,0,3,1,1,N," & strQuote & strQuote & vbCrLf ' same here
Print #1, "A112,64,0,1,1,1,N," & strQuote & "04/13/2009" & strQuote & vbCrLf
Print #1, "A130,100,0,1,1,1,N," & strQuote & "SWAB, NASO" & strQuote & vbCrLf
Print #1, "A4,100,0,1,1,1,N," & strQuote & "C146536" & strQuote & vbCrLf
Print #1, "B53,130,0,1,1,0,47,N," & strQuote & "2009-06868" & strQuote & vbCrLf
Print #1, "A112,188,0,1,1,1,N," & strQuote & "" & strQuote & vbCrLf
Print #1, "P1,1" & vbCrLf
Print #1, "O" & vbCrLf
' close printer port
Close #1
End Sub
Nothing happens after running the function. It's like the printer is not touched at all by the code.
UPDATE
Method 1 is the closest thing I can get to printing the file. After executing the command, there is a printer icon at the status bar show that the printer has been called and receiving data from my code, but still, no printing at all. Help...
if it is mapped to a parallel or com port, you can open that directly:
open "LPT1:" For Output as #1
' or open "COM1:"
print #1, "SomeData"
Close #1
What I like to do is do something similar to your Method 2, but save it to a file (the raw printer data) and then do a file copy to the UNC path.
file copy "C:\label.txt" \computername\sharename
That works for me.
Okay so this is how I managed to get thing this work. Not a best option as I wanted but ... it works.
1) I use the same function, but written in C++, taken from here http://support.microsoft.com/kb/138594/EN-US
// RawDataToPrinter - sends binary data directly to a printer
//
// Params:
// szPrinterName - NULL terminated string specifying printer name
// lpData - Pointer to raw data bytes
// dwCount - Length of lpData in bytes
//
// Returns: TRUE for success, FALSE for failure.
//
BOOL RawDataToPrinter(LPSTR szPrinterName, LPBYTE lpData, DWORD dwCount)
{
HANDLE hPrinter;
DOC_INFO_1 DocInfo;
DWORD dwJob;
DWORD dwBytesWritten;
// Need a handle to the printer.
if( ! OpenPrinter( szPrinterName, &hPrinter, NULL ) )
return FALSE;
// Fill in the structure with info about this "document."
DocInfo.pDocName = "My Document";
DocInfo.pOutputFile = NULL;
DocInfo.pDatatype = "RAW";
// Inform the spooler the document is beginning.
if( (dwJob = StartDocPrinter( hPrinter, 1, (LPSTR)&DocInfo )) == 0 )
{
ClosePrinter( hPrinter );
return FALSE;
}
// Start a page.
if( ! StartPagePrinter( hPrinter ) )
{
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// Send the data to the printer.
if( ! WritePrinter( hPrinter, lpData, dwCount, &dwBytesWritten ) )
{
EndPagePrinter( hPrinter );
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// End the page.
if( ! EndPagePrinter( hPrinter ) )
{
EndDocPrinter( hPrinter );
ClosePrinter( hPrinter );
return FALSE;
}
// Inform the spooler that the document is ending.
if( ! EndDocPrinter( hPrinter ) )
{
ClosePrinter( hPrinter );
return FALSE;
}
// Tidy up the printer handle.
ClosePrinter( hPrinter );
// Check to see if correct number of bytes were written.
if( dwBytesWritten != dwCount )
return FALSE;
return TRUE;
}
I got the file RAWPRN.EXE from there, put my EPL code in a txt file. Finally, use Shell to execute it
Dim RetVal
RetVal = Shell("cmd .exe /c C:\rawprint\RawPrint.exe ""ZDesigner LP 2844"" ""C:\eplcode.txt""", 1)
My solution for Zebra
Creating a generic/text printer in windows then sending to raw file to this printer
In Zebra printers advanced settings --> others,
there is a passthrough characters. You can send raw text with this to this printer.
I use this solution, works perfect.
make a generic text printer, following this recipe
Map the printer to LPT1, using "net use lpt1 \\computername\printername /persistent:yes
Send files to the printer, using:
VBA
Public function runCmd(cmd as String) as Boolean
Dim wsh As Object
Dim cmdToRun As String
Dim Sts As Integer
Set wsh = VBA.CreateObject("WScript.Shell")
cmdToRun = "cmd.exe /c " & Quote(cmd)
'Run & wait to complete
Sts = wsh.Run(cmdToRun, 0, 1)
If Sts = 0 Then
runCmd = True
Else
MsgBox cmd & vbCrLf & "Failed with error code " & Sts
End If
Set wsh = Nothing
End Function
Using cmd : : "cd {dir} & Print \D:LPT1 [file [file]]"

MS Script Control in VBA

I generally use VB.Net for programming but I have been delegated to a VBA project that would benefit from using script control for running script. Here is sample code but errors out on the .Run line of code. I can do this in VB.Net easy but can't get it to work in vba.
ERROR = Wrong number of arguments or invalid property assignent
Option Explicit
Dim sc As New ScriptControl
Sub RunFunctions()
MsgBox (Eval("2 * PI"))
End Sub
Function Eval(expr As String) As Object
Dim code As String
code = "Dim PI" & vbCrLf & _
"PI = 3.1416" & vbCrLf & _
" " & vbCrLf & _
"Function Result" & vbCrLf & _
" Result = " & expr & vbCrLf & _
"End Function"
sc.Language = "VBScript"
sc.AllowUI = True
sc.AddCode (code)
Dim myparams() as variant
Eval = sc.Run("Result", myparams)
End Function
Using the .Eval function from the script control object runs ok in vba but does not run scripts. Here is an example of that if someone cares to know...
Sub SimpleTask()
Dim expr As String
sc.Language = "VBScript"
expr = "2 + 2 * 50"
MsgBox sc.Eval(expr)
End Sub
I think the issue is with your parameters to sc.Run. Try changing this call from
Eval = sc.Run("Result", myparams)
to
Eval = sc.Run("Result")
Update
Here is a complete form using your code that compiles and runs correctly:
Option Explicit On
Option Strict On
Imports MSScriptControl
Public Class Form1
Dim sc As New ScriptControl
Sub RunFunctions()
MsgBox(Eval("2 * PI"))
End Sub
Function Eval(expr As String) As Object
Dim code As String
code = "Dim PI" & vbCrLf & _
"PI = 3.1416" & vbCrLf & _
" " & vbCrLf & _
"Function Result" & vbCrLf & _
" Result = " & expr & vbCrLf & _
"End Function"
sc.Language = "VBScript"
sc.AllowUI = True
sc.AddCode(code)
Dim myparams() As Object
Eval = sc.Run("Result")
End Function
Sub SimpleTask()
Dim expr As String
sc.Language = "VBScript"
expr = "2 + 2 * 50"
MsgBox(sc.Eval(expr))
End Sub
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
SimpleTask()
RunFunctions()
End Sub
End Class
Here is the final working code for VBA. competent_tech has one for VB.Net.
Option Explicit
Dim sc As New ScriptControl
Sub RunFunctions()
MsgBox (Eval("2 * PI"))
End Sub
Function Eval(expr As String) As String
Dim code As String
code = "Dim PI" & vbCrLf & _
"PI = 3.1416" & vbCrLf & _
" " & vbCrLf & _
"Function Result" & vbCrLf & _
" Result = " & expr & vbCrLf & _
"End Function"
sc.Language = "VBScript"
sc.AllowUI = True
sc.AddCode (code)
Eval = sc.Run("Result")
End Function

how to display the listbox items to a label using VB2008

I am trying to display listbox items in a label.
After debugging,I get the error : " make sure that the maximun index on the list is less than the list size"
any comment will be highly appreciate,
Private Sub xMultiButton_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles xMultiButton.Click
Dim count As Integer
count = Me.xNamesListBox.Items.Count
For count = 0 To 3
Me.xResultLabel.Text = Me.xNamesListBox.SelectedItems.Item(0).ToString & ControlChars.NewLine _
& Me.xNamesListBox.SelectedItems.Item(1).ToString & ControlChars.NewLine _
& Me.xNamesListBox.SelectedItems.Item(2).ToString & ControlChars.NewLine _
& Me.xNamesListBox.SelectedItems.Item(3).ToString & ControlChars.NewLine _
& Me.xNamesListBox.SelectedItems.Item(4).ToString
Next
End Sub
You can use For Each for display all selected items of a listbox
For Each Str As String In xNamesListBox.SelectedItems
xResultLabel.Text += Str & Environment.NewLine
Next
try this
For i As Int16 = 0 To xNamesListBox.SelectedItems.Count - 1
xResultLabel.Text += xNamesListBox.SelectedItems.Item(i).ToString() & ControlChars.NewLine
Next