|
|
All the subjects will be grouped (about 10-15 per page) for an easy download and update.
How to ...
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Const CB_ERR = (-1)
Private Const CB_FINDSTRING = &H14C
Private Const CB_LIMITTEXT = &H141
Dim rez&, l&, t$
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Combo1.SelText = ""
t$ = Combo1.Text & Chr$(KeyAscii)
rez& = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, t$)
If rez& <> CB_ERR Then
l& = Len(t$)
Combo1.Text = Combo1.List(rez&)
KeyAscii = 0
Combo1.SelStart = l&
Combo1.SelLength = Len(Combo1.Text) - l&
End If
End Sub
Private Sub Form_Load()
SendMessage Combo1.hwnd, CB_LIMITTEXT, 10&, 0&
End Sub
Public Const VER_PLATFORM_WIN32s = 0
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2
'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long 'size, in bytes, of this data structure
dwVerMajor As Long 'ie NT 3.51, dwVerMajor = 3; NT 4.0, dwVerMajor = 4.
dwVerMinor As Long 'ie NT 3.51, dwVerMinor = 51; NT 4.0, dwVerMinor= 0.
dwBuildNumber As Long 'NT: build number of the OS
'Win9x: build number of the OS in low-order word.
' High-order word contains major & minor ver nos.
PlatformID As Long 'Identifies the operating system platform.
szCSDVersion As String * 128 'NT: string, such as "Service Pack 3"
'Win9x: 'arbitrary additional information'
End Type
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Public Function IsWin95() As Boolean
'returns True if running Win95
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_WINDOWS and
'dwVerMajor = 4, and dwVerMinor = 0,
'return true
IsWin95 = (OSV.PlatformID = VER_PLATFORM_WIN32_WINDOWS) And _
(OSV.dwVerMajor = 4 And OSV.dwVerMinor = 0)
End If
End Function
Public Function IsWin98() As Boolean
'returns True if running Win98
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_WINDOWS and
'dwVerMajor => 4, or dwVerMajor = 4 and
'dwVerMinor > 0, return true
IsWin98 = (OSV.PlatformID = VER_PLATFORM_WIN32_WINDOWS) And _
(OSV.dwVerMajor > 4) Or _
(OSV.dwVerMajor = 4 And OSV.dwVerMinor > 0)
End If
End Function
Public Function IsWinNT4() As Boolean
'returns True if running WinNT4
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_NT and dwVerMajor is 4, return true
IsWinNT4 = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And _
(OSV.dwVerMajor = 4)
End If
End Function
Public Function IsWinNT5() As Boolean
'returns True if running WinNT2000 (NT5)
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing the OS.
'If VER_PLATFORM_WIN32_NT and dwVerMajor is 5, return true
IsWinNT5 = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And _
(OSV.dwVerMajor = 5)
End If
End Function
Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32
Private Type NCB
ncb_command As Byte 'Integer
ncb_retcode As Byte 'Integer
ncb_lsn As Byte 'Integer
ncb_num As Byte ' Integer
ncb_buffer As Long 'String
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte 'Integer
ncb_sto As Byte ' Integer
ncb_post As Long
ncb_lana_num As Byte 'Integer
ncb_cmd_cplt As Byte 'Integer
ncb_reserve(9) As Byte ' Reserved, must be 0
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte 'As String * 6
rev_major As Byte 'Integer
reserved0 As Byte 'Integer
adapter_type As Byte 'Integer
rev_minor As Byte 'Integer
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" _
(pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" _
(ByVal hHeap As Long, ByVal dwFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, _
ByVal dwFlags As Long, lpMem As Any) As Long
Private Function EthAddr(LanaNumber As Long) As String
Dim udtNCB As NCB
Dim bytResponse As Byte
Dim udtASTAT As ASTAT
Dim udtTempASTAT As ASTAT
Dim lngASTAT As Long
Dim strOut As String
Dim x As Integer
udtNCB.ncb_command = NCBRESET
bytResponse = Netbios(udtNCB)
udtNCB.ncb_command = NCBASTAT
udtNCB.ncb_lana_num = LanaNumber
udtNCB.ncb_callname = "* "
udtNCB.ncb_length = Len(udtASTAT)
lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS _
Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
strOut = ""
If lngASTAT Then
udtNCB.ncb_buffer = lngASTAT
bytResponse = Netbios(udtNCB)
CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
With udtASTAT.adapt
For x = 0 To 5
strOut = strOut & Right$("00" & Hex$(.adapter_address(x)), 2)
Next x
End With
HeapFree GetProcessHeap(), 0, lngASTAT
End If
EthAddr = strOut
End Function
Declare Function RasEnumConnections Lib "RasApi32.DLL" _
Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, _
lpcConnections As Long) As Long
Function RASCount() As Integer
Dim lprasconn(0 To 1) As Long ' dummy buffer area
Dim rc As Long ' return code
Dim lpcb As Long ' buffer size
Dim lpcConnections As Long ' connection count
lprasconn(0) = 32 ' each returned item is at least 32 bytes long
lpcb = 0 ' set total number of usable bytes in the buffer to zero
rc = RasEnumConnections(lprasconn(0), lpcb, lpcConnections)
RASCount = lpcConnections ' return connection count
End Function
You can use it with code like:
If RASCount() Then
MsgBox "Connected"
Else
MsgBox "Not connected"
End If
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 Command1_Click()
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(Text2.Text, lhPrinter, 0)
If lReturn = 0 Then
MsgBox "The Printer Name you typed wasn't recognized."
Exit Sub
End If
MyDocInfo.pDocName = "Num " & Text1.Text
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
'MyDocInfo.pDatatype = vbInteger
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
' Call StartPagePrinter(lhPrinter)
'sWrittenData = "How's that for Magic !!!!" & vbFormFeed
sWrittenData = Text1.Text
'lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), lpcWritten)
lReturn = WritePrinter(lhPrinter, ByVal sWrittenData, _
Len(sWrittenData), 0)
'lReturn = EndPagePrinter(lhPrinter)
'lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
'Text1.Text = ""
'Debug.Print lReturn & "Es"
End Sub
'if you need send any byte by lpt1 then you can use CreateFile, TransmitCommChar and CloseFile.
Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3
Public Const OPEN_ALWAYS = 4
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_SHARE_WRITE = &H2
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal
lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As
Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long,
ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function TransmitCommChar Lib "kernel32" (ByVal nCid As Long, ByVal cChar As Byte) As Long
Dim hport As Long
Private Sub Command1_Click()
Dim Num As Long
Dim Result As Long
Dim LPTPORT As String
LPTPORT = "LPT1"
hport = CreateFile(LPTPORT, GENERIC_WRITE, FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, ByVal 0&)
If hport = INVALID_HANDLE_VALUE Then
MsgBox "Invalid Handle, Error Num:" & Err.LastDllError, vbCritical, "Error"
Exit Sub
End If
Result = TransmitCommChar(hport, CInt(Text1.Text))
Command2.SetFocus
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
Result = CloseHandle(hport)
Command1.Enabled = True
Command1.SetFocus
End Sub
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long Private Const CB_INITSTORAGE = &H161 'pentru a initializa spatiul unde se inregistreaza informatia Private Const CB_ADDSTRING = &H143 Private Sub Command1_Click() Dim lRet As Long lRet = SendMessageLong(Combo1.hwnd, CB_INITSTORAGE, 10000, 10000) For lRet = 1 To 10000 lRet = SendMessageString(Combo1.hwnd, CB_ADDSTRING, &O0, "1") Next lRet End Sub
----------- Form1 Code --------------- Private Sub Command1_Click() Form2.Show End Sub Private Sub Form_Load() For i = 1 To 25 Combo1.AddItem "Item" & i Next Combo1.ListIndex = 0 End Sub ----------- Form2 Code --------------- Private Declare Function SetParent Lib _ "user32" (ByVal hWndChild As Long, ByVal _ hWndNewParent As Long) As Long Private Sub Form_Activate() SetParent Form1.Combo1.hWnd, hWnd End Sub Private Sub Form_Unload(Cancel As Integer) SetParent Form1.Combo1.hWnd, Form1.hWnd End Sub
Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Const LVS_EX_FULLROWSELECT = &H20 Private Const LVM_FIRST = &H1000 Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H37 Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H36 Public Sub ExtendListView(lvwExtend As Object) Dim lStyle As Long lStyle = SendMessage(lvwExtend.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0) lStyle = lStyle Or LVS_EX_FULLROWSELECT Call SendMessage(lvwExtend.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, ByVal lStyle) End Sub
Private Const LF_FACESIZE = 32 Private Const MAXFACENAME = LF_FACESIZE - 1 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * MAXFACENAME End Type Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Dim lf As LOGFONT Dim oOldFont As Integer Dim oFont As Integer Dim x As Integer Dim strText As String strText = "Testing" Me.ScaleMode = vbPixels lf.lfHeight = 15 ' may need to play with these to adjust the size lf.lfWidth = 14 lf.lfWeight = 400 ' the Escapement rotates it in tenths of degrees; negative is down lf.lfEscapement = -900 lf.lfItalic = 0 ' no special characteristics for this demo lf.lfUnderline = 0 lf.lfStrikeOut = 0 lf.lfOutPrecision = 0 lf.lfClipPrecision = 0 lf.lfQuality = 0 lf.lfPitchAndFamily = 0 lf.lfCharSet = 0 lf.lfFaceName = "Arial" & Chr$(0) ' base font name oFont = CreateFontIndirect(lf) ' create a font temporarily If oFont = 0 Then MsgBox "error!": Exit Sub oOldFont = SelectObject(Me.hdc, oFont) ' tell the form to use the new font ' draw the text on the form x = TextOut(Me.hdc, Me.ScaleWidth / 2, Me.ScaleHeight / 2, strText, _ Len(strText)) x = SelectObject(Me.hdc, oOldFont) ' restore original font x = DeleteObject(oFont) ' delete temporary font
© VB Work 2000, Last update