 |
|
 |
 | Surse simple 1 |  |
 Trimis: 04/09/2007 17:27 |
 |
|
| Ad_Infinitum |
| Administrator |
 |
 |
| Data inscrierii: 23/Iun/2007 |
| Mesaje: 212 |
|
|
|
|
|
 |
|
1) Cum pot obtine adresa curenta de la IE sau Netscape Navigator ?
Pun un textbox (DDEText) apoi scriu:
strApplication = "IEXPLORE" ' Pentru Internet Explorer
strApplication = "NETSCAPE" ' Pentru Netscape
strDDETopic = strApplication & "|WWW_GetWindowInfo"
With DDEText
.LinkTopic = strDDETopic
.LinkItem = "0xFFFFFFFF"
.LinkMode = 2
.LinkRequest
End With
sCurrentURL = Mid(DDEText.Text, 2, InStr(DDEText.Text, ",") - 3)
2) Cum lansez browserul Internet implicit cu o anumita adresa ?
Private 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 nShowCmd As Long) As Long
Const SW_MAXIMIZE = 3
Private Sub Command1_Click()
Dim lRet As Long
lRet = ShellExecute(Me.hwnd, "open","http://www.geocities.com/siliconvalley/hills/4377", _
vbNullString, vbNullString, SW_MAXIMIZE)
End Sub
3) Rezolutia ecranului
Public Function GetScreenResolution() As String
Dim TWidth As Long
Dim THeight As Long
TWidth = Screen.Width \ Screen.TwipsPerPixelX
THeight = Screen.Height \ Screen.TwipsPerPixelY
GetScreenResolution = TWidth & "x" & THeight
End Function
4) Cum lansez dialogul 'Find File' ?
Pun un label chiar invizibil pe ecran (lbl_DDE), apoi:
With lbl_DDE
.LinkTopic = "Folders|AppProperties"
.LinkMode = vbLinkManual
.LinkExecute "[OpenFindFile(,)]"
End With
5) Apelare 'Help' din meniu propriu
Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long,
ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As
Long
Public Const HELP_CONTEXT = &H1 ' Display topic in ulTopic
Public Const HELP_HELPONHELP = &H4 ' Display help on using help
Public Const HELP_INDEX = &H3 ' Display index
Public Const HELP_QUIT = &H2 ' Terminate help
Public Const HELP_SETINDEX = &H5 ' Set current Index for multi
index help
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&
Private Sub MnuHelpContents_Click()
Dim Help_path As String
Dim RV As Long
Help_path = App.HelpFile
RV = WinHelp(Me.hwnd, Help_path, &H3, CLng(0))
End Sub
6) Dezactivarea butonului de inchidere a ferestrei ('X')
Public Sub DisableCloseButton(frm as Form)
Dim hMenu As Long
Dim menuItemCount As Long
hMenu = GetSystemMenu(frm.hWnd, 0)
If hMenu Then
menuItemCount = GetMenuItemCount(hMenu)
'este pe ultima pozitie (menuItemCount-1)
RemoveMenu hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION
'Sterg separatorul de linie
RemoveMenu hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION
DrawMenuBar frm.hWnd
End If
End Sub
Declaratiile functiilor GetSystemMenu, GetMenuItemCount, RemoveMenu, DrawMenuBar si a constantelor MF_REMOVE si MF_BYPOSITION se gasesc cu API Viewer.
7) Toolbar (flat) stil IE sau MS Office
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As
Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As
Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Const WM_USER = &H400
Private Const TB_SETSTYLE = WM_USER + 56
Private Const TB_GETSTYLE = WM_USER + 57
Private Const TBSTYLE_FLAT = &H800
Private Const TBSTYLE_LIST = &H1000
Public Sub CoolBar(tlb As Toolbar, tlbToolbarStyle As Long)
Dim lngStyle As Long, lngResult As Long, lngHWND As Long
' Find child window and get style bits
lngHWND = FindWindowEx(tlb.hwnd, 0&, "ToolbarWindow32", vbNullString)
lngStyle = SendMessage(lngHWND, TB_GETSTYLE, 0&, 0&)
Select Case tlbToolbarStyle
Case 1
'Creates an Office97 Toolbar
lngStyle = lngStyle Or TBSTYLE_FLAT
Case 2
'Creates an IE4 stsyle toolbar with text to the right of the picture.
'You must supply text in order to get the effect
lngStyle = lngStyle Or TBSTYLE_FLAT Or TBSTYLE_LIST
Case Else
lngStyle = lngStyle Or TBSTYLE_FLAT
End Select
'Use the API call to change the Toolbar effect
lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)
tlb.Refresh
End Sub
sper sa va fie de folos  |
|
|
|
|
| Surse simple 1.2 | |
| Trimis: 04/09/2007 17:58 |
|
|
| Ad_Infinitum |
| Administrator |
|
|
| Data inscrierii: 23/Iun/2007 |
| Mesaje: 212 |
|
|
|
|
|
|
|
1) Obtinerea numelui simplu (8.3) a unei caii (Lucian Gadau)
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Public Function GetShortPath(filespec) As String
Dim lpath As String, spath As String
Dim lspath As Long, ccode As Long
lspath = 256
GetShortPath = Space(lspath)
GetShortPathName filespec, GetShortPath, lspath
GetShortPath = Left(Trim(GetShortPath), Len(Trim(GetShortPath)) - 1)
End Function
2) Lansarea unei aplicatii externe si asteptarea terminarii ei (RunApp) (Lucian Gadau)
Public Const CREATE_NEW_CONSOLE = &H10
Public Const CREATE_NEW_PROCESS_GROUP = &H200
Public Const CREATE_NO_WINDOW = &H8000000
Public Const CREATE_SUSPENDED = &H4
Public Const CREATE_UNICODE_ENVIRONMENT = &H400
Public Const CREATE_SEPARATE_WOW_VDM = &H800
Public Const CREATE_SHARED_WOW_VDM = &H1000
Public Const CREATE_FORCEDOS = &H2000
Public Const CREATE_DEFAULT_ERROR_MODE = &H4000000
'Public Const CREATE_NO_WINDOW = &H8000000
Public Const DETACHED_PROCESS = &H8
Public Const DEBUG_PROCESS = &H1
Public Const DEBUG_ONLY_THIS_PROCESS = &H2
Public Const NORMAL_PRIORITY_CLASS = &H20
Public Const IDLE_PRIORITY_CLASS = &H40
Public Const HIGH_PRIORITY_CLASS = &H80
Public Const REALTIME_PRIORITY_CLASS = &H100
Public Const STATUS_PENDING = &H103
Public Const STILL_ACTIVE = STATUS_PENDING
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Public Declare Function CreateProcess Lib "kernel32" Alias _
"CreateProcessA" (ByVal lpApplicationName As String, ByVal _
lpCommandLine As String, lpProcessAttributes As Any, _
lpThreadAttributes As Any, ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal _
lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
ByRef lpExitCode As Long _
) As Long
Public Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long)
Public Sub RunApp(AppName As String)
Dim ExitCode As Long
Dim sNull As String
Dim lpProcessAttributes As SECURITY_ATTRIBUTES
Dim lpThreadAttributes As SECURITY_ATTRIBUTES
Dim lpEnvironment As Variant
Dim lpStartupInfo As STARTUPINFO
Dim lpProcessInformation As PROCESS_INFORMATION
'initialization of variables
lpProcessAttributes.bInheritHandle = 0
lpProcessAttributes.lpSecurityDescriptor = 0
lpProcessAttributes.nLength = Len(lpProcessAttributes)
lpThreadAttributes.bInheritHandle = 0
lpThreadAttributes.lpSecurityDescriptor = 0
lpThreadAttributes.nLength = Len(lpProcessAttributes)
lpStartupInfo.cb = Len(lpStartupInfo)
'lpStartupInfo.dwFlags = STARTF_USESHOWWINDOW
'lpStartupInfo.wShowWindow = SW_SHOWDEFAULT
lpStartupInfo.lpDesktop = ""
lpStartupInfo.cbReserved2 = 0
lpStartupInfo.lpReserved = ""
lpStartupInfo.lpTitle = ""
lpStartupInfo.lpReserved2 = 0
CreateProcess sNull, AppName, lpProcessAttributes, lpThreadAttributes, _
vbNull, NORMAL_PRIORITY_CLASS, ByVal 0&, sNull, lpStartupInfo, lpProcessInformation
GetExitCodeProcess lpProcessInformation.hProcess, ExitCode
While ExitCode <> 0
GetExitCodeProcess lpProcessInformation.hProcess, ExitCode
DoEvents 'don't forget, you're not the only one in the world
Sleep 2000
Wend
End Sub
3) Cautare rapida in ListBox sau ComboBox (Serban Tomita)
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 CB_FINDSTRING = &H14C
Private Const CB_FINDSTRINGEXACT = &H158
Private Const LB_FINDSTRING = &H18F
Private Const LB_FINDSTRINGEXACT = &H1A2
Public Function FFM(ByVal ctlSearch As Control, ByVal SearchString As String, _
ByVal FirstRow As Integer, ByVal Riguros As Boolean) As Integer
Dim Index As Long
On Error Resume Next
If TypeOf ctlSearch Is ComboBox Then
If Precis Then
Index = SendMessage(ctlSearch.hWnd, CB_FINDSTRINGEXACT, FirstRow, ByVal SearchString)
Else
Index = SendMessage(ctlSearch.hWnd, CB_FINDSTRING, FirstRow, ByVal SearchString)
End If
ElseIf TypeOf ctlSearch Is ListBox Then
If Exact Then
Index = SendMessage(ctlSearch.hWnd, LB_FINDSTRINGEXACT, FirstRow, ByVal SearchString)
Else
Index = SendMessage(ctlSearch.hWnd, LB_FINDSTRING, FirstRow, ByVal SearchString)
End If
End If
FFM = Index
End Function
Exemplu de utilizare:
List1.ListIndex = FFM(List1, text_de_cautat, -1, True)
Combo1.ListIndex = FFM(Combo1, text_de_cautat, -1, True)
4) Afisarea proprietatilor unui fisier
Private Declare Function ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" _
(shInfo As SHELLEXECUTEINFO) As Long
Private Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
' Optional fields
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Dim s As SHELLEXECUTEINFO
Private Const SEE_MASK_FLAG_NO_UI = &H400
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_INVOKEIDLIST = &HC
Private Sub cmdProperties_Click()
s.cbSize = Len(s)
s.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
s.hwnd = Me.hwnd
s.lpVerb = "Properties"
s.lpFile = txtFile.Text
s.lpParameters = Chr(0)
s.lpDirectory = Chr(0)
s.nShow = 0
s.hInstApp = 0
s.lpIDList = 0
ShellExecuteEx s
End Sub
5) Blocarea unei ferestre
Desi se poate folosi
Declare Function LockWindowUpdate Lib "user32" Alias "LockWindowUpdate" (ByVal hwndLock As Long) As Long
nu este recomandata de MS (in excepțional pt. NT). Se poate folosi in schimb:
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" =
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As =
Any) As Long
Public Const WM_SETREDRAW = &HB
SendMessage Me.hwnd, WM_SETREDRAW, False, 0
' Executa ceva...
SendMessage Me.hwnd, WM_SETREDRAW, True, 0
6) Lista proceselor curente (Alexandru Andrei)
Pentru a vedea executabilele care ruleaza la un ocazie dat, se poate folosi functia Windows EnumWindowsProc ca in exemplul urmator (vb5).
Codul pt. Forma:
VERSION 5.00
Begin VB.Form frmGhost
Caption = "Ghost"
ClientHeight = 2745
ClientLeft = 4350
ClientTop = 3285
ClientWidth = 4575
LinkTopic = "Form1"
ScaleHeight = 2745
ScaleWidth = 4575
Begin VB.CommandButton btnExit
Caption = "Exit"
Height = 375
Left = 2520
TabIndex = 2
Top = 2280
Width = 1335
End
Begin VB.CommandButton btnAction
Caption = "Hide"
Height = 375
Left = 720
TabIndex = 1
Top = 2280
Width = 1335
End
Begin VB.ListBox lstApp
Height = 2010
ItemData = "frmGhost.frx":0000
Left = 120
List = "frmGhost.frx":0002
TabIndex = 0
Top = 120
Width = 4335
End
End
Attribute VB_Name = "frmGhost"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub btnAction_Click()
HideOrShow lstApp
SetActionName btnAction, lstApp
End Sub
Private Sub btnExit_Click()
Unload Me
End Sub
Private Sub Form_Load()
RefreshAppList lstApp
End Sub
Private Sub lstApp_Click()
SetActionName btnAction, lstApp
End Sub
Codul pt. Modul:
Attribute VB_Name = "Ghost"
Declare Function EnumWindows Lib "user32" (ByVal lpEnumWindows As Long, _
LParam As Any) As Boolean
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Boolean
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Boolean
Function EnumWindowsProc(ByVal hWnd As Long, lstApp As ListBox) As Boolean
If GetParent(hWnd) = 0 And IsWindowVisible(hWnd) Then
Dim strAppName As String
strAppName = Space(256)
GetWindowText hWnd, strAppName, 256
strAppName = Left$(strAppName, InStr(strAppName, vbNullChar) - 1)
If strAppName <> "" And strAppName <> "Ghost" Then
lstApp.AddItem strAppName
lstApp.ItemData(lstApp.NewIndex) = hWnd
End If
End If
EnumWindowsProc = True
End Function
Public Sub RefreshAppList(lstApp As ListBox)
EnumWindows AddressOf EnumWindowsProc, lstApp
End Sub
Public Sub SetActionName(btnAction As CommandButton, lstApp As ListBox)
Dim hWnd As Long
hWnd = lstApp.ItemData(lstApp.ListIndex)
btnAction.Caption = IIf(IsWindowVisible(hWnd), "Hide", "Show")
End Sub
Public Sub HideOrShow(lstApp As ListBox)
Dim hWnd As Long, nCmdShow As Long
hWnd = lstApp.ItemData(lstApp.ListIndex)
nCmdShow = IIf(IsWindowVisible(hWnd), 0, 5)
ShowWindow hWnd, nCmdShow
End Sub
7) Cel mai rapid mod de lucru cu stringuri
Merge doar intr-un fisier bas compilat (exe) nu din IDE.
Private Declare Function strchr Lib "MSVCRT.dll" (ByVal sTarget$, ByVal nPattern&) As Long
Sub Main()
Dim i&, sTarget$, sPattern$, nTotalFound&
sTarget = "PROGRAMMING"
sPattern = "PRM"
For i = 1 To Len(sPattern)
If strchr(sTarget, Asc(Mid$(sPattern, i, 1))) Then nTotalFound = nTotalFound + 1
Next
MsgBox CStr(nTotalFound)
End Sub
8) Scrierea in Event Log pt. Win NT
Option Explicit
Declare Function RegisterEventSource Lib "advapi32.dll" Alias _
"RegisterEventSourceA" (ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) As Long
Declare Function DeregisterEventSource Lib "advapi32.dll" ( _
ByVal hEventLog As Long) As Long
Declare Function ReportEvent Lib "advapi32.dll" Alias _
"ReportEventA" (ByVal hEventLog As Long, ByVal wType As Integer, _
ByVal wCategory As Integer, ByVal dwEventID As Long, _
ByVal lpUserSid As Any, ByVal wNumStrings As Integer, _
ByVal dwDataSize As Long, plpStrings As Long, _
lpRawData As Any) As Boolean
Declare Function GetLastError Lib "kernel32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, _
ByVal cbCopy As Long)
Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long
'-- Public Constants
Public Const EVENTLOG_SUCCESS = 0
Public Const EVENTLOG_ERROR_TYPE = 1
Public Const EVENTLOG_WARNING_TYPE = 2
Public Const EVENTLOG_INFORMATION_TYPE = 4
Public Const EVENTLOG_AUDIT_SUCCESS = 8
Public Const EVENTLOG_AUDIT_FAILURE = 10
Public Function WriteToEventLog(sMessage As String, _
sSource As String, _
iLogType As Integer, _
vEventID As Integer) As Boolean
Dim bRC As Boolean
Dim iNumStrings As Integer
Dim hEventLog As Long
Dim hMsgs As Long
Dim cbStringSize As Long
Dim iEventID As Integer
hEventLog = RegisterEventSource("", sSource)
cbStringSize = Len(sMessage) + 1
hMsgs = GlobalAlloc(&H40, cbStringSize)
CopyMemory ByVal hMsgs, ByVal sMessage, cbStringSize
iNumStrings = 1
'-- ReportEvent returns 0 if failed,
'-- Any other number indicates success
If ReportEvent(hEventLog, _
iLogType, 0, _
iEventID, 0&, _
iNumStrings, cbStringSize, _
hMsgs, hMsgs) = 0 Then
'-- Failed
WriteToEventLog = False
Else
'-- Sucessful
WriteToEventLog = True
End If
Call GlobalFree(hMsgs)
DeregisterEventSource (hEventLog)
End Function
sau
App.LogEvent "Error No : " & vbCrLf & Err.Number & vbCrLf & "Source : " & vbCrLf & _
"[name of dll and message]" & Err.Source & vbCrLf & "Description :" & vbCrLf & _
Err.Description, vbLogEventTypeError
9) Determinarea bazelor de date disponibile pe un MS SQL Server (cu RDO)
Private Sub LoadDatabases()
Dim RDOConn As RDO.rdoConnection
Dim rs As rdoResultset
Dim sql As String
On Error GoTo LoadDatabasesError
Set RDOConn = New rdoConnection
'--- handle errors locally
With RDOConn
.Connect = "SERVER=" & ServerName & ";UID=" & UserID & =";PWD=" & _
Password & ";DRIVER={SQL Server};DSN=;"
.LoginTimeout = 5
.EstablishConnection
End With
cboDatabases.Clear
sql = "select * "
sql = sql & "from master.dbo.sysdatabases"
Set rs = RDOConn.OpenResultset(sql)
If rs.EOF Then
cboDatabases.Enabled = False
Else
Do While Not rs.EOF
cboDatabases.AddItem rs.rdoColumns(0).Value
rs.MoveNext
Loop
End If
End Select
If Not rs Is Nothing Then Set rs = Nothing
If Not RDOConn Is Nothing Then Set RDOConn = Nothing
Exit Sub
LoadDatabasesError:
MsgBox Err.Number & ":" & Err.Description, , "Load Databases"
Exit Sub
End Sub
10) Seteaza/obtine intervalul de timp pt. dublu-click
Declare Function SetDoubleClickTime Lib "user32" Alias "SetDoubleClickTime" _
(ByVal wCount As Long) As Long
Declare Function GetDoubleClickTime& Lib "user32" ()
'set double-click time in milliseconds
setDoubleClickTime(500)
'retrieve the mouse double-click time in milliseconds
Dim lngReturn As Long
lngReturn = GetDoubleClickTime
11) Creaza shortcut-uri pe ecran si in Start Menu
'NOTE: In Visual Basic 5.0, change Stkit432.dll in the following
'statement to Vb5stkit.dll. Stkit432.dll is for Visual Basic 4.0
Private Declare Function fCreateShellLink Lib "STKIT432.DLL" _
(ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Dim lReturn As Long
'Add to Desktop
lReturn = fCreateShellLink("..\..\Desktop", _
"Shortcut to Calculator", "c:\windows\calc.exe", "")
'Add to Program Menu Group
lReturn = fCreateShellLink("", "Shortcut to Calculator", _
"c:\windows\calc.exe", "")
'Add to Startup Group
'Note that on Windows NT, the shortcut will not actually appear
'in the Startup group until your next reboot.
lReturn = fCreateShellLink("\Startup", "Shortcut to Calculator", _
"c:\windows\calc.exe", "")
 ioi da multe-s  |
|
|
|
|
|
|
