Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Limitez nr. de caractere intr-un Combo si executa auto-cautare (ca in Access)

   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
   

2. Verificarea sistemului de operare

   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
   

3. Obtinerea adresei placii de retea (Ethernet)

   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
   

4. Verifica conexiunea prin Dial-Up

   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
   

5. Listarea direct la imprimanta folosind API Windows

       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
   

6. Exemplu de adaugare intr-un Combo folosind API Windows

   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
   

7. Copiez un Combo dintr-o forma in alta

   Pun o forma cu un combo si un buton de comanda si o forma goala.

   ----------- 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
   

8. Selectia intregii linii intr-un ListView

   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
   

9. Scriere de texte cu font rotit

   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