(Manuale) Vb6 - Visual Basic 6 Ita - Codice Trucchi

 I listati sono suddivisi per capitoli e per argomento all'interno di ciascun capitolo.

Capitolo 1 – Il linguaggio Interpretato o compilato?  Function DebugMode() As Boolean On Error Resume Next Debug.Print 1 / 0 DebugMode = (Err <> 0) Err.Clear End Function Function DebugMode() As Boolean Static Counter As Variant If IsEmpty(Counter) Then Counter = 1 Debug.Assert DebugMode() Or True Counter = Counter - 1 ElseIf Counter = 1 Then Counter = 0 End If DebugMode = Counter End Function

Attenzione agli elementi di un ParamArray  Function Max(ParamArray args() As Variant) As Variant Dim result As Variant, index As Integer result = args(LBound(args)) For index = LBound(args) + 1 To UBound(args) If result < args(index) Then result = args(index) Next Max = result End Function Function Max(ParamArray args() As Variant) As Variant Dim result As Variant, index As Integer For index = LBound(args) To UBound(args) If IsMissing(args(index)) Then ' ignora questo argomento ElseIf IsEmpty(result) Then ' la prima volta si imposta un possibile valore di ritorno result = args(index) ElseIf result < args(index) Then result = args(index) End If Next Max = result End Function

Confrontare velocemente gli UDT  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) ' una struttura UDT d'esempio che contiene praticamente ogni possibile tipo di dato Private Type MyUDT item1 As Boolean item2(10) As Integer item3 As Long item4 As Single item5 As Double item6 As Currency item7 As String * 20 End Type Dim udt1 As MyUDT, udt2 As MyUDT ' inizializza il primo UDT udt1.item1 = 10 udt1.item2(1) = 4 udt1.item3 = 12345 udt1.item4 = 345.567 udt1.item5 = 111.333444 udt1.item6 = 223344.5566 udt1.item7 = "this is a test" ' inizializza il secondo UDT

' (in questo test entrambi gli UDT contengono lo stesso valore) udt2 = udt1 ' il numero di byte da confrontare Dim bytes As Long bytes = LenB(udt1) ' le stringhe utilizzate per il confronto Dim s1 As String, s2 As String ' le rende sufficientemente grandi da ospitare gli UDT s1 = Space$((bytes + 1) \ 2) s2 = s1 ' copia gli UDT nelle stringhe CopyMemory ByVal StrPtr(s1), ByVal VarPtr(udt1), bytes CopyMemory ByVal StrPtr(s2), ByVal VarPtr(udt2), bytes ' ora è possibile effettuare il confronto If s1 = s2 Then MsgBox "Equal" Else MsgBox "Different" End If

Creare un valore Missing  ' non passare mai un argomento a questa funzione Function MissingValue(Optional DontPassMe As Variant) As Variant ' se viene passato un argomento, solleva l'errore "Invalid Procedure Call" If Not IsMissing(DontPassMe) Then Err.Raise 5 MissingValue = DontPassMe End Function

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) Function MissingValue() As Variant ' un valore "missing" è in realtà un codice d'errore pari al valore esadecimale 80020004 ' pertanto qui viene memorizzata la parte intera di tale valore MissingValue = &H80020004 ' e quindi si modifica il VarType in vbError (= 10) CopyMemory MissingValue, 10, 2 End Function

' (in questo test entrambi gli UDT contengono lo stesso valore) udt2 = udt1 ' il numero di byte da confrontare Dim bytes As Long bytes = LenB(udt1) ' le stringhe utilizzate per il confronto Dim s1 As String, s2 As String ' le rende sufficientemente grandi da ospitare gli UDT s1 = Space$((bytes + 1) \ 2) s2 = s1 ' copia gli UDT nelle stringhe CopyMemory ByVal StrPtr(s1), ByVal VarPtr(udt1), bytes CopyMemory ByVal StrPtr(s2), ByVal VarPtr(udt2), bytes ' ora è possibile effettuare il confronto If s1 = s2 Then MsgBox "Equal" Else MsgBox "Different" End If

Creare un valore Missing  ' non passare mai un argomento a questa funzione Function MissingValue(Optional DontPassMe As Variant) As Variant ' se viene passato un argomento, solleva l'errore "Invalid Procedure Call" If Not IsMissing(DontPassMe) Then Err.Raise 5 MissingValue = DontPassMe End Function

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) Function MissingValue() As Variant ' un valore "missing" è in realtà un codice d'errore pari al valore esadecimale 80020004 ' pertanto qui viene memorizzata la parte intera di tale valore MissingValue = &H80020004 ' e quindi si modifica il VarType in vbError (= 10) CopyMemory MissingValue, 10, 2 End Function

Capitolo 2 - Numeri e Date Convertire numeri esadecimali  Function HexToDec(HexValue As String) As Long HexToDec = Val("&H" & HexValue) End Function Function HexToDec(HexValue As String, Optional ToInteger As Boolean) As Long If ToInteger Then ' converte in un intero, se possibile ' Utilizzare CInt() se si desidera convertire *sempre* in un Integer HexToDec = Val("&H" & HexValue) Else ' converte sempre in un Long. È anche possibile utilizzare la funzione CLng(). HexToDec = Val("&H" & HexValue & "&") End If End Function

Nuove funzioni matematiche per VB  ' logaritmo in base 10 Function Log10(number As Double) As Double Log10 = Log(number) / 2.30258509299405 End Function ' conversione da gradi in radianti Function DegreesToRadians(ByVal degrees As Single) As Single DegreesToRadians = degrees / 57.29578 End Function ' conversione da radianti in gradi Function RadiansToDegrees(ByVal radians As Single) As Single RadiansToDegrees = radians * 57.29578 End Function ' la parte frazionaria di un numero ' (argomenti negativi restituiscono valori negativi) Function Fract(number As Variant) As Variant Fract = number - Fix(number) End Function ' Un numero casuale nell'intervallo [low,high] Function Rnd2(low As Single, high As Single) As Single Rnd2 = Rnd * (high - low) + low End Function ' Cotangente di un angolo dato Function Cot(radians As Double) As Double Cot = 1 / Tan(radians) End Function ' arcotangent di Y/X – a differenza di ATN() ' restituisce un angolo nei quattro quadranti Function Atn2(x As Double, y As Double) As Double If x = 0 Then Atn2 = Sgn(y) * 1.5707963267949 ElseIf x > 0 Then Atn2 = Atn(y / x) Else Atn2 = Atn(y / x) + 3.14159265358979 * Sgn(y) End If End Function ' Il fattoriale di un numero ' errore se l'argomento è negativo o maggiore di 170 Function Factorial(ByVal number As Long) As Double Static result(170) As Double ' questa routine è molto veloce perché precalcola ' in anticipo tutti i possibili risultati If result(0) = 0 Then ' questa è la prima esecuzione Dim i As Long

result(0) = 1 For i = 1 To 170 result(i) = result(i - 1) * i Next End If ' ora occorre solo restituire un elemento del vettore Factorial = result(number) End Function

Contare i bit in un intero  Function BitCount (ByVal number As Long) As Integer Dim bits As Integer, temp As Long temp = number Do While temp temp = temp And (temp - 1) bits = bits + 1 Loop BitCount = bits End Function

Manipolare i bit di un numero  ' Testa il valore di un bit Function BitTest(ByVal value As Long, ByVal bit As Long) As Boolean BitTest = (value And Power2(bit)) End Function ' Imposta a True (1) il valore di un bit Function BitSet(ByVal value As Long, ByVal bit As Long) As Long BitSet = (value Or Power2(bit)) End Function ' Imposta a False(0) il valore di un bit Function BitClear(ByVal value As Long, ByVal bit As Long) As Long BitClear = (value And Not Power2(bit)) End Function ' Calcola la potenza di 2 ' l'esponente deve essere nell'intervallo [0,31] Function Power2(ByVal exponent As Long) As Long Static res(0 To 31) As Long Dim i As Long If exponent < 0 Or exponent > 31 Then Err.Raise 5 ' inizializza il vettore alla prima chiamata If res(0) = 0 Then res(0) = 1 For i = 1 To 30 res(i) = res(i - 1) * 2 Next ' questo è un caso speciale res(31) = &H80000000 End If ' restituisce il risultato Power2 = res(exponent) End Function

Un semplice valutatore di espressioni  Function EvalExpression(ByVal expression As String) As Double Dim result As Double Dim operand As Double Dim opcode As String Dim index As Integer Dim lastIndex As Integer ' il carattere null marca la fine della stringa expression = expression & vbNullChar For index = 1 To Len(expression) + 1 If InStr("+-*/" & vbNullChar, Mid$(expression, index, 1)) Then If lastIndex = 0 Then ' questo è il primo operando dell'espressione result = Val(Left$(expression, index - 1)) Else ' estrae il nuovo operando operand = Val(Mid$(expression, lastIndex, index - lastIndex)) ' esegue l'operazione in sospeso Select Case opcode Case "+"

result = result + Case "-" result = result Case "*" result = result * Case "/" result = result / End Select End If opcode = Mid$(expression, lastIndex = index + 1 End If Next EvalExpression = LTrim$(result)

operand operand operand operand index, 1)

End Function

L'età di una persona  Function Age(BirthDate As Date, Optional CurrentDate As Variant, _ Optional ExactAge As Boolean) As Integer If IsMissing(CurrentDate) Then CurrentDate = Now Age = Year(CurrentDate) - Year(BirthDate) If ExactAge Then ' sottrae uno se la data del compleanno dell'anno corrente deve ancora arrivare If DateSerial(Year(CurrentDate), Month(BirthDate), _ Day(BirthDate)) > CurrentDate Then Age = Age - 1 End If End If End Property

Tecniche con DateSerial  ' l'ultimo giorno di un dato mese Function EndOfMonth(Year As Integer, Month As Integer) As Date EndOfMonth = DateSerial(Year, Month + 1, 0) End Function ' il numero di giorni in un mese Function DaysInMonth(Year As Integer, Month As Integer) As Integer DaysInMonth = Day(DateSerial(Year, Month + 1, 0)) End Function ' True se si tratta di un anno bisestile Function IsLeapYear(Year As Integer) As Boolean IsLeapYear = (Day(DateSerial(Year, 3, 0)) = 29) End Function

Una versione migliorata della funzione DatePart  Enum DateTimePart dtYear dtQuarter dtMonth dtMonthName dtShortMonthName dtDay dtDayOfTheYear dtWeekday dtWeekdayName dtShortWeekdayName dtWeekOfTheYear dtHour dtMinute dtSecond End Enum ' La funzione DatePart migliorata Function DatePartEx(ByVal Interval As DateTimePart, newDate As Date, _ Optional FirstDayOfWeek As VbDayOfWeek = vbSunday, Optional FirstWeekOfYear _ As VbFirstWeekOfYear = vbFirstJan1) As Variant ' Seleziona la funzione data/ora corretta e più veloce Select Case Interval Case dtYear DatePartEx = Year(newDate) Case dtQuarter DatePartEx = DatePart("q", newDate, FirstDayOfWeek, FirstWeekOfYear) Case dtMonth DatePartEx = Month(newDate) Case dtMonthName DatePartEx = MonthName(Month(newDate), False) Case dtShortMonthName DatePartEx = MonthName(Month(newDate), True)

Case dtDay DatePartEx = Day(newDate) Case dtDayOfTheYear DatePartEx = DatePart("y", newDate, FirstDayOfWeek, FirstWeekOfYear) Case dtWeekday DatePartEx = Weekday(newDate, FirstDayOfWeek) Case dtWeekdayName DatePartEx = Format(newDate, "dddd") Case dtShortWeekdayName DatePartEx = Format(newDate, "ddd") Case dtWeekOfTheYear DatePartEx = DatePart("ww", newDate, FirstDayOfWeek, _ FirstWeekOfYear) Case dtHour DatePartEx = Hour(newDate) Case dtMinute DatePartEx = Minute(newDate) Case dtSecond DatePartEx = Second(newDate) End Select End Function

Benchmark accurati al millisecondo  Private Type SMPTE hour As Byte min As Byte sec As Byte frame As Byte fps As Byte dummy As Byte pad(2) As Byte End Type Private Type MMTIME wType As Long units As Long smpteVal As SMPTE songPtrPos As Long End Type Private Declare Function timeGetSystemTime Lib "winmm.dll" (lpTime As MMTIME, _ ByVal uSize As Long) As Long ' restituisce l'ora attuale del sistema (in millisecondi) Function GetCurrentTime() As Long ' assegna questo valore al campo wType per ' specificare le misure temporali in millisecondi Const TIME_MS = 1 Dim mmt As MMTIME mmt.wType = TIME_MS timeGetSystemTime mmt, LenB(mmt) GetCurrentTime = mmt.units End Function

Estrarre le informazioni sul fuso orario  Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Type TIME_ZONE_INFORMATION Bias As Long StandardName(32) As Integer StandardDate As SYSTEMTIME StandardBias As Long DaylightName(32) As Integer DaylightDate As SYSTEMTIME DaylightBias As Long End Type Private Declare Function GetTimeZoneInformation Lib "kernel32" _ (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long ' restituisce le differenze di fuso orario dall'ora di Greenwich ' ' ad esempio -5 per New York, +1 per Roma Function GetTimeZone() As Single Dim tzInfo As TIME_ZONE_INFORMATION GetTimeZoneInformation tzInfo

GetTimeZone = tzInfo.Bias / 60 End Function ' ---- versione migliorata Private Declare Function GetTimeZoneInformationAny Lib "kernel32" Alias _ "GetTimeZoneInformation" (buffer As Any) As Long ' restituisce la differenza di fuso orario dall'ora di Greenwich ' ' ad esempio -5 per New York, +1 per Roma Function GetTimeZone() As Single Dim buffer(0 To 44) As Long GetTimeZoneInformationAny buffer(0) GetTimeZone = buffer(0) / -60 End Function ' ---- versione che tiene conto dell'ora legale Private Function GetTimeZone() As Single Dim retval As Long Dim buffer(0 To 42) As Long Const Const Const Const

TIME_ZONE_ID_INVALID = &HFFFFFFFF TIME_ZONE_ID_UNKNOWN = 0 TIME_ZONE_ID_STANDARD = 1 TIME_ZONE_ID_DAYLIGHT = 2

retval = GetTimeZoneInformationAny(buffer(0)) Select Case lreturnval Case TIME_ZONE_ID_INVALID, TIME_ZONE_ID_UNKNOWN GetTimeZone = 0 Case TIME_ZONE_ID_STANDARD GetTimeZone = (buffer(0) + buffer(21)) / 60 'oppure (tzinfo.bias+tzinfo.standardbias)/60 Case TIME_ZONE_ID_DAYLIGHT GetTimeZone = (buffer(0) + buffer(42)) / 60 'oppure (tzinfo.bias+tzinfo.Daylightbias)/60 Case Else GetTimeZone = 0 End Select End Function ' ---- versione finale Private Function GetTimeZone() As Single Dim retval As Long Dim buffer(0 To 42) As Long Const Const Const Const

TIME_ZONE_ID_INVALID = &HFFFFFFFF TIME_ZONE_ID_UNKNOWN = 0 TIME_ZONE_ID_STANDARD = 1 TIME_ZONE_ID_DAYLIGHT = 2

retval = GetTimeZoneInformationAny(buffer(0)) Select Case retval Case TIME_ZONE_ID_INVALID GetTimeZone = 0 Case TIME_ZONE_ID_STANDARD, TIME_ZONE_ID_UNKNOWN GetTimeZone = (buffer(0) + buffer(21)) / 60 'oppure (tzinfo.bias+tzinfo.standardbias)/60 Case TIME_ZONE_ID_DAYLIGHT GetTimeZone = (buffer(0) + buffer(42)) / 60 'oppure (tzinfo.bias+tzinfo.Daylightbias)/60 Case Else GetTimeZone = 0 End Select End Function

Eseguire benchmark con la funzione API  QueryPerformanceCounter  Private Declare Function QueryPerformanceFrequencyAny Lib "kernel32" Alias _ "QueryPerformanceFrequency" (lpFrequency As Any) As Long Private Declare Function QueryPerformanceCounterAny Lib "kernel32" Alias _ "QueryPerformanceCounter" (lpPerformanceCount As Any) As Long Private Sub Command1_Click() Dim frequency As Currency

Dim startTime As Currency Dim endTime As Currency Dim result As Double ' ottiene il contatore della frequenza ' restituisce zero se l'hardware non gestisce contatori di prestazioni ad alta risoluzione If QueryPerformanceFrequencyAny(frequency) = 0 Then MsgBox "This computer doesn't support high-res timers", vbCritical Exit Sub End If ' avvia la misurazione QueryPerformanceCounterAny startTime ' inserire in questo punto il codice da misurare, ad esempio... Dim i As Long For i = 1 To 1000000 Next ' termina la misurazione QueryPerformanceCounterAny endTime ' sia il dividendo che il divisore sono scalati di un fattore ' 10.000, pertanto non è necessario scalare il risultato result = (endTime - startTime) / frequency ' show the result MsgBox result End Sub

Estrarre le word da un valore Long  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) ' restituisce la word più significativa di un valore a 32-bit Function HiWord(ByVal value As Long) As Integer CopyMemory HiWord, ByVal VarPtr(value) + 2, 2 End Function ' restituisce la word meno significativa di un valore a 32-bit Function LowWord(ByVal value As Long) As Integer CopyMemory LowWord, value, 2 End Function

Capitolo 3 - Stringhe Convertire opportunamente maiuscole e minuscole  Function ProperCase(text As String) As String Dim i As Integer ' prepara il risultato ProperCase = StrConv(text, vbProperCase) ' ripristina tutti i caratteri che sono stati convertiti in minuscolo For i = 1 To Len(text) Select Case Asc(Mid$(text, i, 1)) Case 65 To 90 ' A-Z Mid$(ProperCase, i, 1) = Mid$(text, i, 1) End Select Next End Function

Varianti della funzione InStr  Function InstrLast(ByVal Start As Long, Source As String, search As String, _ Optional CompareMethod As VbCompareMethod = vbBinaryCompare) As Long Do ' ricerca l'occorrenza successiva con InStr Start = InStr(Start, Source, search, CompareMethod) If Start = 0 Then Exit Do ' ne abbiamo trovata una InstrLast = Start Start = Start + 1 Loop ' il valore restituito è l'ultima occorrenza trovata End Function ' ' ' '

se Include è True o omesso, restituisce la prima occorrenza di uno dei caratteri specificati in Table, oppure zero se la ricerca fallisce se Include è False, restituisce la prima occorrenza di un qualsiasi carattere che NON compare in Table

Function InstrTbl(ByVal Start As Long, Source As String, Table As String, _ Optional Include As Boolean = True, Optional CompareMethod As _ VbCompareMethod = vbBinaryCompare) As Long Dim i As Long For i = Start To Len(Source) If InStr(1, Table, Mid$(Source, i, 1), CompareMethod) > 0 Xor Not _ Include Then InstrTbl = i Exit Function End If Next End Function

Estrarre le parole con l'oggetto RegExp  ' Ottiene una collezione di tutte le parole di una stringa ' Se il secondo argomento è True, vengono restituite solo le parole univoche. ' ' NOTA: richiede un riferimento alla type library ' Microsoft VBScript Regular Expression Function GetWords(ByVal Text As String, Optional DiscardDups As Boolean) As _ Collection Dim re As New RegExp Dim ma As Match ' il pattern seguente significa che si ricerca una lettera (\w) ' ripetuta una o più volte (il suffisso +) che si trova agli estremi di una parola ' (le sequenze \b iniziale e finale) re.Pattern = "\b\w+\b" ' ricerca *tutte* le occorrenze del pattern re.Global = True ' inizializza il risultato Set GetWords = New Collection ' è necessario ignorare gli errori, se bisogna eliminare i duplicati On Error Resume Next ' il metodo Execute esegue la ricerca e restituisce un oggetto MatchCollection For Each ma In re.Execute(Text) If DiscardDups Then ' se bisogna eliminare i duplicati, basta aggiungere semplicemente una chiave ' alla collezione degli elementi

' ed il metodo Add si farà carico dell'operazione GetWords.Add ma.Value, ma.Value Else ' altrimenti basta aggiungere al risultato GetWords.Add ma.Value End If Next End Function '--------- esempio ----------------' Conta quanti articoli appaiono in una stringa sorgente ' contenuta nella casella di testo txtSource Dim v As Variant Dim count As Long For Each v In GetWords(txtSource.Text) Select Case LCase$(v) Case "the", "a", "an" count = count + 1 End Select Next MsgBox "Found " & count & " articles."

Ricercare più sottostringhe con l'oggetto RegExp  ' NOTA: questo codice richiede un riferimento alla type library ' Microsoft VBScript Regular Expression Dim re As New RegExp Dim ma As Match re.Pattern = "january|february|march|april|may|june|july|september|october" _ & "|november|december" ' le differenze tra maiuscole e minuscole non sono significative re.IgnoreCase = True ' si vogliono tutte le occorrenze del pattern re.Global = True ' si assume che la stringa da analizzare sia contenuta nella variabile sourceText For Each ma In re.Execute(sourceText) Print "Found '" & ma.Value & "' at index " & ma.FirstIndex Next ' ricerca tutte le parole specificate nel vettore passato come secondo argomento ' restituisce una matrice bidimensionale di Variant, dove arr(0,n) è l'n-esima ' parola corrispondente ed arr(1,n) è l'indice al quale è stata trovata la parola ' NOTA: richiede un riferimento alla type library ' Microsoft VBScript Regular Expression Function InstrAllWords(ByVal Text As String, words() As String, _ Optional IgnoreCase As Boolean) As Variant Dim re As New RegExp Dim ma As Match Dim maCol As MatchCollection Dim index As Long ' crea il pattern nella forma "\b(word1|word2|....|wordN)\b" re.pattern = "\b(" & Join(words, "|") & ")\b" ' si vogliono tutte le occorrenze del pattern re.Global = True ' le differenze tra maiuscole e minuscole non sono significative? re.IgnoreCase = IgnoreCase ' ottiene il risultato Set maCol = re.Execute(Text) ' ora è possibile dimensionare la matrice risultato ReDim res(1, maCol.Count) As Variant ' sposta i risultato nella matrice For Each ma In maCol index = index + 1 res(0, index) = ma.Value res(1, index) = ma.FirstIndex Next ' return to caller InstrAllWords = res End Function '------- esempio di utilizzo ---------

' popola una matrice con le parole desiderate Dim words(2) As String words(0) = "Visual": words(1) = "Basic": words(2) = "Windows" Dim arr() as Variant arr = InstrAllWords(txtSource.Text, words()) For i = 1 To UBound(arr, 2) Print "'" & arr(0, i) & "' at index " & arr(1, i) Next

Capitolo 4 - Array e Collection Le variabili semplici sono sempre più veloci degli elementi dei  vettori  Function AnyDuplicates(intArray() As Integer) As Boolean ' restituisce True se il vettore contiene valori duplicati Dim i As Long, j As Long, Dim lastItem As Long Dim value As Integer ' calcola UBound() una sola volta lastItem = UBound(intArray) For i = LBound(intArray) To lastItem ' memorizza intArray(i) in una variabile semplice (non vettore) ' risparmia un'operazione di indicizzazione all'interno del ciclo interno value = intArray(i) For j = i + 1 To lastItem If value = intArray(j) Then AnyDuplicates = True Exit Function End If Next Next ' non sono stati trovati duplicati AnyDuplicates = False End Function

Eliminare i duplicati in un vettore  ' ' ' ' ' ' ' ' ' ' ' ' '

Filter out duplicate values in an array and compact the array by moving items to "fill the gaps". Returns the number of duplicate values it works with arrays of any type, except objects The array is not REDIMed, but you can do it easily using the following code: a() is a string array dups = FilterDuplicates(a()) If dups Then ReDim Preserve a(LBound(a) To UBound(a) - dups) As String End If

Function FilterDuplicates(arr As Variant) As Long Dim col As Collection, index As Long, dups As Long Set col = New Collection On Error Resume Next For index = LBound(arr) To UBound(arr) ' build the key using the array element ' an error occurs if the key already exists col.Add 0, CStr(arr(index)) If Err Then ' we've found a duplicate arr(index) = Empty dups = dups + 1 Err.Clear ElseIf dups Then ' if we've found one or more duplicates so far ' we need to move elements towards lower indices arr(index - dups) = arr(index) arr(index) = Empty End If Next ' return the number of duplicates FilterDuplicates = dups End Function '-------- esempio ---------------' a() è un vettore di stringhe che contiene duplicati Dups = FilterDuplicates(a()) If dups Then ReDim Preserve a(Lbound(a) To Ubound(a) – dups) As String End If

Una tecnica non documentata per velocizzare le funzioni che  restituiscono vettori  ' restituisce un vettore di N elementi casuali ' e memorizza la rispettiva media in AVG Function GetRandomArray(ByVal n As Long, avg As Single) As Single() Dim i As Long, sum As Single ReDim res(1 To n) As Single ' popola il vettore con valori casuali e ne calcola il totale Randomize Timer For i = 1 To n res(i) = Rnd sum = sum + res(i) Next ' assegna il vettore al risultato quindi calcola la media GetRandomArray = res avg = sum / n End Function '------- variante ottimizzata ----------' restituisce un vettore di N elementi casuali ' e memorizza la rispettiva media in AVG Function GetRandomArray(ByVal n As Long, avg As Single) As Single() Dim i As Long, sum As Single ReDim res(1 To n) As Single ' popola il vettore con valori casuali e ne calcola il totale Randomize Timer For i = 1 To n res(i) = Rnd sum = sum + res(i) Next ' calcola la media QUINDI assenga la matrice risultato avg = sum / n GetRandomArray = res End Function

Una routine per il sort di un vettore  Sub ShellSort(arr As Variant, Optional lastEl As Variant, _ Optional descending As Boolean) Dim value As Variant Dim index As Long, index2 As Long Dim firstEl As Long Dim distance As Long Dim numEls As Long ' gestisci il parametro opzionale If IsMissing(lastEl) Then lastEl = UBound(arr) firstEl = LBound(arr) numEls = lastEl - firstEl + 1 ' trova il valore migliore per distance Do distance = distance * 3 + 1 Loop Until distance > numEls Do distance = distance \ 3 For index = distance + firstEl To lastEl value = arr(index) index2 = index Do While (arr(index2 - distance) > value) Xor descending arr(index2) = arr(index2 - distance) index2 = index2 - distance If index2 - distance < firstEl Then Exit Do Loop arr(index2) = value Next Loop Until distance = 1 End Sub

CountSort, un caso particolare di ordinamento indicizzato  Sub NdxCountSortI(arr() As Integer, ndx() As Long, Optional ByVal numEls As _ Variant) Dim index As Long Dim inverseOrder As Boolean Dim value As Integer Dim minValue As Integer Dim maxValue As Integer Dim saveCount As Integer Dim newIndex As Long

' tiene conto degli argomenti ordinati If IsMissing(numEls) Then numEls = UBound(arr) ' cerca i valori minimo e massimo minValue = arr(LBound(arr)) maxValue = minValue For index = LBound(arr) To numEls value = arr(index) If value < minValue Then minValue = value ElseIf value > maxValue Then maxValue = value End If Next ' dichiara la matrice di indici temporanea ReDim Count(minValue To maxValue) As Long ' popola ogni elemento della matrice temporanea con ' il numero di occorrenze del valore in questione For index = LBound(arr) To numEls value = arr(index) Count(value) = Count(value) + 1 Next ' analizza la matrice count() per sostituire il valore di count ' con la posizione definitiva ' nella matrice ordinata newIndex = LBound(ndx) For index = minValue To maxValue saveCount = Count(index) Count(index) = newIndex newIndex = newIndex + saveCount Next ' infine crea l'indice For index = LBound(arr) To numEls ' ottiene la posizione dell'elemento nell'indice newIndex = Count(arr(index)) ' memorizza la posizione originale ndx(newIndex) = index ' la volta successiva memorizza il valore nell'elemento seguente Count(arr(index)) = newIndex + 1 Next End Sub

Ordinare rispetto a più chiavi  Type TEmployees name As String * 40 dept As String * 12 salary As Currency End Type ' carica il vettore dal disco ReDim employees(1 To 1) As TEmployees Open "employees.dat" For Binary As #1 numEls = LOF(1) / Len(employees(1)) ReDim employees(1 To numEls) As TEmployees Get #1, , employees() Close #1 ' crea un vettore temporaneo contenente i dati chiave ReDim keys(1 To numEls) As String For index = 1 To numEls keys(index) = employees(index).dept & employees(index).name Next ' esegue l'ordinamento indicizzato discendente ReDim ndx(1 To numEls) As Long ' questa routine può essere scaricata dal seguente URL ' http://www.vb2themax.com/Item.asp?PageID=CodeBank&ID=78 NdxShellSort keys(), ndx(), , True ' visualizza il nome degli impiegati ' per ciascun dipartimento dept = "" For index = 1 To numEls With employees(ndx(index)) If .dept <> dept Then dept = .dept Debug.Print "Dept: " & dept End If Debug.Print .name, .salary End With Next

Ricerca binaria in un vettore ordinato  Function BinarySearch(arr As Variant, search As Variant, _ Optional lastEl As Variant) As Long Dim index As Long Dim first As Long Dim last As Long Dim middle As Long Dim inverseOrder As Boolean ' gestisci il parametro opzionale If IsMissing(lastEl) Then lastEl = UBound(arr) first = LBound(arr) last = lastEl ' deduci la direzione dell'ordinamento inverseOrder = (arr(first) > arr(last)) BinarySearch = first - 1 Do middle = (first + last) \ 2 If arr(middle) = search Then BinarySearch = middle Exit Do ElseIf ((arr(middle) < search) Xor inverseOrder) Then first = middle + 1 Else last = middle - 1 End If Loop Until first > last End Function

Velocizzare le ricerche con le tabelle di hash  Function Checksum(text As String) As Long Dim sum As Long, i As Long Dim bArray() As Byte ' trasforma in un vettore di byte bArray() = StrConv(text, vbFromUnicode) ' calcola la somma degli elementi del vettore For i = 0 To UBound(bArray) sum = sum + bArray(i) * i Next Checksum = sum End Function ' ----- lettura parole da disco numEls = 10000 ReDim words(numEls) As String ReDim hashTable(2 * numEls) As Integer ' legge le parole da un file Open "words.dat" For Input As #1 For index = 1 To numEls Line Input#1, words(index) Next Close #1 ' ----- inserimento delle parole For index = 1 To numEls ' ricerca l'indice di hash corretto hashIndex = Checksum(words(index)) ' cicla fino a che non si trova uno slot libero Do hashIndex = (hashIndex Mod numEls) + 1 Loop While hashTable(hashIndex) ' Memorizza l'indice nella tabella di hash hashTable(hashIndex) = index Next ' ---------- ricerca --------------search = Text1.Text hashIndex = Checksum(search) Do hashIndex = (hashIndex Mod numEls) + 1 Loop While hashTable(hashIndex) And words(hashTable(hashIndex)) <> search If hashTable(hashIndex) Then Print "Item found at index " & hashTable(hashIndex) Else Print "Item not found" End If

Il numero di dimensioni di una matrice  Function ArrayDims(arr As Variant) As Integer Dim i As Integer, bound As Long On Error Resume Next For i = 1 To 60 bound = LBound(arr, i) If Err Then ArrayDims = i - 1 Exit Function End If Next End Function Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) Function ArrayDims(arr As Variant) As Integer Dim ptr As Long Dim VType As Integer Const VT_BYREF = &H4000& ' ottiene il VarType effetivo dell'argomento ' questo è simile al VarType(), ma restituisce anche il bit VT_BYREF CopyMemory VType, arr, 2 ' esce se non si tratta di una matrice If (VType And vbArray) = 0 Then Exit Function ' ottiene l'indirizzo del descrittore SAFEARRAY ' questo viene memorizzato nella seconda metà del parametro ' Variant che contiene la matrice CopyMemory ptr, ByVal VarPtr(arr) + 8, 4 ' vede se alla matrice è stato passato un Variant ' contenente una matrice, piuttosto che direttamente una matrice ' nel primo caso ptr punta già alla struttura SA. If (VType And VT_BYREF) Then ' ptr è un puntatore a un puntatore CopyMemory ptr, ByVal ptr, 4 End If ' ottiene l'indirizzo della struttura SAFEARRAY ' questo è memorizzato nel descrittore ' ottiene la prima parola della struttura SAFEARRAY ' che contiene il numero di dimensioni ' ...ma prima controlla che saAddr sia diverso da zero, altrimenti ' la routine non funziona quando la matrice viene deinizializzata If ptr Then CopyMemory ArrayDims, ByVal ptr, 2 End If End Function

Capitolo 5 - Form e controlli Spostare il focus con i tasti freccia su e freccia giù  Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyUp Then If TypeOf ActiveControl Is TextBox Then ' freccia su – passa al controllo precedente SendKeys "+{Tab}" KeyCode = 0 End If ElseIf KeyCode = vbKeyDown Then If TypeOf ActiveControl Is TextBox Then ' freccia giù – passa al controllo successivo SendKeys "{Tab}" KeyCode = 0 End If End If End Sub

Modificare aspetto delle TextBox e ComboBox disabilitate  ' abilita/disabilita una casella di testo o una casella combinata ' (modifica anche i relativi sfondi) Sub EnableTextBox(tb As Control, ByVal Enabled As Boolean) tb.Enabled = Enabled If Enabled Then tb.BackColor = vbWindowBackground Else tb.BackColor = vbInactiveBorder End If End Sub

Assicurarsi che i controlli TextBox e ComboBox di una form  abbiano la stessa altezza  ' modifica l'altezza di tutte le caselle di testo a riga singola di una form Sub SetTextboxHeight(frm As Form, ByVal Height As Single) Dim ctrl As Control For Each ctrl In frm.Controls If TypeOf ctrl Is TextBox Then If ctrl.MultiLine = False Then ctrl.Height = Height End If End If Next End Sub Private Sub Form_Load() SetTextboxHeight Me, Combo1.Height End Sub

Verificare se una form è caricata o meno  ' restituisce il numero delle istanze di una form ' attualmente caricate Function FormCount(ByVal frmName As String) As Long Dim frm As Form For Each frm In Forms If StrComp(frm.Name, frmName, vbTextCompare) = 0 Then FormCount = FormCount + 1 End If Next End Function

Modificare lo stile di un controllo CheckBox o OptionButton a  runtime  Private Declare (ByVal hWnd Private Declare (ByVal hWnd

Function As Long, Function As Long,

Const GWL_STYLE = (-16)

GetWindowLong Lib "user32" Alias "GetWindowLongA" _ ByVal nIndex As Long) As Long SetWindowLong Lib "user32" Alias "SetWindowLongA" _ ByVal nIndex As Long, ByVal newValue As Long) As Long

Const BS_PUSHLIKE = &H1000& Sub SetButtonStyle(Ctrl As Control, ByVal Graphical As Boolean) If Graphical Then SetWindowLong Ctrl.hWnd, GWL_STYLE, GetWindowLong(Ctrl.hWnd, _ GWL_STYLE) Or BS_PUSHLIKE Else SetWindowLong Ctrl.hWnd, GWL_STYLE, GetWindowLong(Ctrl.hWnd, _ GWL_STYLE) And Not BS_PUSHLIKE End If Ctrl.Refresh End Sub

Modificare le dimensioni del cursore testo e l'intermittenza del  lampeggio  Declare Function CreateCaret Lib "user32" (ByVal hWnd As Long, _ ByVal hBitmap As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Declare Function ShowCaret Lib "user32" (ByVal hWnd As Long) As Long Declare Function SetCaretBlinkTime Lib "user32" (ByVal wMSeconds As Long) As _ Long Declare Function GetCaretBlinkTime Lib "user32" () As Long Sub ShowCustomCaret(ByVal width As Integer, ByVal height As Integer) On Error Resume Next With Screen.ActiveForm.ActiveControl CreateCaret .hWnd, 0, width, height ShowCaret .hWnd End With End Sub

Modificare la proprietà ShowInTaskbar a runtime  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_APPWINDOW = &H40000 Private Sub Form_Load() ' nasconde la form sulla taskbar SetWindowLong Me.hWnd, GWL_EXSTYLE, (GetWindowLong(hWnd, _ GWL_EXSTYLE) And Not WS_EX_APPWINDOW) End Sub Private Sub Form_Load() ' mostra la form sulla taskbar SetWindowLong Me.hWnd, GWL_EXSTYLE, (GetWindowLong(hWnd, _ GWL_EXSTYLE) Or WS_EX_APPWINDOW) End Sub

Modificare la larghezza dell'elenco a discesa di una  ComboBox  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 Const CB_SETDROPPEDWIDTH = &H160 ' imposta la larghezza dell'area dell'elenco di una ComboBox (in pixel) Sub SetComboDropDownWidth(ComboBox As ComboBox, ByVal lWidth As Long) SendMessage ComboBox.hWnd, CB_SETDROPPEDWIDTH, lWidth, ByVal 0& End Sub

Clonare un oggetto Font  Function CloneFont(Font As StdFont) As StdFont Set CloneFont = New StdFont CloneFont.Name = Font.Name CloneFont.Size = Font.Size CloneFont.Bold = Font.Bold CloneFont.Italic = Font.Italic CloneFont.Underline = Font.Underline CloneFont.Strikethrough = Font.Strikethrough End Function Function CloneFont(Font As StdFont) As StdFont Dim pb As New PropertyBag ' copia le proprietà Font in un oggetto PropertyBag

pb.WriteProperty "Font", Font ' e quindi crea da questo un nuovo oggetto Font Set CloneFont = pb.ReadProperty("Font") End Function Function CloneFont(Font As IFont) As StdFont Font.Clone CloneFont End Function

Impostare correttamente la larghezza e l'altezza delle barre di  scorrimento  Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) _ As Long Sub ResizeAllScrollbars(frm As Object) Dim hsbHeight As Single Dim vsbWidth As Single Dim ctrl As Control Const SM_CXVSCROLL = 2 Const SM_CYHSCROLL = 3 ' determina le dimensioni suggerite per le barre di scorrimento (in twips) hsbHeight = GetSystemMetrics(SM_CYHSCROLL) * Screen.TwipsPerPixelY vsbWidth = GetSystemMetrics(SM_CXVSCROLL) * Screen.TwipsPerPixelX ' itera su tutti i controlli dalla form For Each ctrl In frm.Controls Select Case TypeName(ctrl) Case "HScrollBar" ctrl.Height = hsbHeight Case "VScrollBar" ctrl.Width = vsbWidth Case "FlatScrollBar" If ctrl.Orientation = 1 Then ctrl.Height = hsbHeight Else ctrl.Width = vsbWidth End If End Select Next End Sub

Aggiungere una barra di scorrimento orizzontale ad un  controllo ListBox  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 Const LB_SETHORIZONTALEXTENT = &H194 Const LB_GETHORIZONTALEXTENT = &H193 ' imposta l'estensione orizzontale del controllo (in pixel). ' Se questo valore è maggiore della larghezza attuale del controllo ' apparirà una barra di scorrimento orizzontale. Sub SetHorizontalExtent(lb As ListBox, ByVal newWidth As Long) SendMessage lb.hwnd, LB_SETHORIZONTALEXTENT, newWidth, ByVal 0& End Sub ' restituisce l'estensione orizzontale del controllo (in pixel). Function GetHorizontalExtent(lb As ListBox) As Long GetHorizontalExtent = SendMessage(lb.hwnd, LB_GETHORIZONTALEXTENT, 0, _ ByVal 0&) End Function

Creare pulsanti di comando colorati  Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As _ Integer Private Sub Form_Load() With Option1 ' sposta il controllo CommandButton sotto l'OptionButton, Command1.Move .Left, .Top, .Width, .Height ' ma restringe le dimensioni di quest'ultimo in modo da rendere visibile il bordo .Move .Left + ScaleX(1, vbPixels, ScaleMode), .Top + ScaleY(1, vbPixels, _ ScaleMode), .Width - 2 * ScaleX(1, vbPixels, ScaleMode), _ .Height - 2 * ScaleY(1, vbPixels, ScaleMode) ' verifica che l'OptionButton sia in primo piano

.ZOrder ' l'utente non può spostarsi con il tab sull'OptionButton .TabStop = False End With End Sub Private Sub Option1_Click() If GetAsyncKeyState(vbKeyLButton) = 0 And Option1.Value Then ' se l'Optionbutton viene attivato tramite una combinazione di tasti ' o l'utente ha premuto il tasto del mouse su di esso e l'ha quindi rilasciato ' è necessario ripristinare il suo aspetto Option1.Value = False ' e quindi scatenare l'evento Click del pulsante vero e proprio Command1.SetFocus Command1.Value = True End If End Sub Private Sub Option1_MouseUp(Button As Integer, Shift As Integer, X As Single, _ Y As Single) ' scatena nuovamente l'evento Click quando il pulsante del mouse viene rilasciato Option1_Click End Sub Private Sub Command1_Click() ' qui va inserito il codice che si desidera eseguire ' quando si preme il pulsante End Sub

Creare controlli ListBox dotati di pulsanti di spostamento  Private Sub cmdUp_Click() ' se il primo elemento non è quello corrente If List1.ListIndex >= 0 Then ' aggiunge un elemento duplicato all'inizio List1.AddItem List1.Text, List1.ListIndex - 1 ' lo rende l'elemento corrente List1.ListIndex = List1.ListIndex - 2 ' elminina la vecchia occorrenza di questo elemento List1.RemoveItem List1.ListIndex + 2 End If End Sub Private Sub cmdDown_Click() ' solo se l'ultimo elemento non è quello corrente If List1.ListIndex <> -1 And List1.ListIndex < List1.ListCount - 1 Then ' aggiunge un elemento duplicato alla fine List1.AddItem List1.Text, List1.ListIndex + 2 ' lo rende l'elemento corrente List1.ListIndex = List1.ListIndex + 2 ' elimina la vecchia occorrenza di questo elemento List1.RemoveItem List1.ListIndex - 2 End If End Sub Private Sub List1_Click() ' abilita/disabilita i pulsanti quando l'elemento corrente cambia cmdUp.Enabled = (List1.ListIndex > 0) cmdDown.Enabled = (List1.ListIndex <> -1 And List1.ListIndex < _ List1.ListCount - 1) End Sub Private Sub Form_Load() ' dal momento che non vi è alcun elemento corrente (ListIndex = -1) ' è necessario invocare manualmente la procedura Click Call List1_Click End Sub

Tagliare, copiare ed incollare con le funzioni API di Windows  Private Const WM_CUT = &H300 Private Const WM_COPY = &H301 Private Const WM_PASTE = &H302 Private Const WM_CLEAR = &H303 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 ' copia il contenuto di un controllo nella Clipboard Sub ControlCopy(ByVal hWnd As Long) SendMessage hWnd, WM_COPY, 0, ByVal 0& End Sub ' taglia il contenuto di un controllo e lo copia nella Clipboard Sub ControlCut(ByVal hWnd As Long) SendMessage hWnd, WM_CUT, 0, ByVal 0&

End Sub ' incolla il contenuto della Clipboard in un controllo Sub ControlPaste(ByVal hWnd As Long) SendMessage hWnd, WM_PASTE, 0, ByVal 0& End Sub ' elimina il contenuto selezionato in un controllo Sub ControlDelete(ByVal hWnd As Long) SendMessage hWnd, WM_CLEAR, 0, ByVal 0& End Sub

Determinare in che modo un controllo ha ottenuto il focus  Private Declare Function GetKeyState Lib "user32" Alias "GetKeyState" (ByVal _ nVirtKey As Long) As Integer Function GotFocusMethod() As Integer If GetKeyState(vbKeyTab) < 0 Then If (GetKeyState(vbKeyShift) < 0) Then ' è stata premuta la combinazione di tasti Shift-Tab GotFocusMethod = 4 Else ' è stato premuto il tasto Tab GotFocusMethod = 1 End If ElseIf GetKeyState(vbKeyMenu) < 0 Then ' è stato premuto il tasto Alt (attivazione della sequenza di tasti) GotFocusMethod = 2 ElseIf GetKeyState(vbLeftButton) < 0 Then ' è stato premuto il pulsante sinistro del mouse GotFocusMethod = 3 End If End Function

Determinare la riga corrente in una casella di testo multiriga  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 Const EM_LINEFROMCHAR = &HC9 Function GetTextBoxCurrentLine(TB As TextBox) As Long GetTextBoxCurrentLine = SendMessage(TB.hWnd, EM_LINEFROMCHAR, -1, _ ByVal 0&) + 1 End Function

Determinare se un controllo possiede una barra di  scorrimento  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Const GWL_STYLE = (-16) Const WS_VSCROLL = &H200000 Const WS_HSCROLL = &H100000 Function HasHorizontalScrollbar(ctrl As Control) As Boolean HasHorizontalScrollbar = (GetWindowLong(ctrl.hwnd, _ GWL_STYLE) And WS_HSCROLL) End Function Function HasVerticalScrollbar(ctrl As Control) As Boolean HasVerticalScrollbar = (GetWindowLong(ctrl.hwnd, GWL_STYLE) And WS_VSCROLL) End Function

Creare una form padre con le funzioni API  Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) Const GWL_HWNDPARENT = (-8) Function SetOwner(ByVal HwndtoUse, ByVal HwndofOwner) As Long SetOwner = SetWindowLong(HwndtoUse, GWL_HWNDPARENT, HwndofOwner) End Function ' ------ esempio --------Dim frm As Form2 Dim oldOwner As Long Private Sub cmdShowForm_Click() ' mostra la form Set frm = Form2

frm.Show ' la rende figlia dela form corrente oldOwner = SetOwner(frm.hwnd, Me.hwnd) End Sub Private Sub cmdUnloadForm_Click() ' ripristina la form padre originale SetOwner frm.hwnd, oldOwner ' scarica la form Unload frm End Sub

Ricevere eventi da un timer mentre è attiva una message box  Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal _ hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, _ ByVal wType As Long) As Long Private Sub Command1_Click() MsgBox "The Timer STOPS!", vbOKOnly, "Regular MsgBox" End Sub Private Sub Command2_Click() MessageBox Me.hWnd, "The Timer DOESN'T STOP", "MessageBox API function", _ vbOKOnly + vbExclamation End Sub Private Sub Timer1_Timer() Label1.Caption = Time End Sub Function MsgBox2(Prompt As String, Optional Buttons As VbMsgBoxStyle, _ Optional Title As Variant) As VbMsgBoxResult If IsMissing(Title) Then Title = App.Title MsgBox2 = MessageBox(Screen.ActiveForm.hWnd, Prompt, Title, Buttons) End Function

Abilitare e disabilitare completamente o in parte la barra di  scorrimento  Private Declare Function EnableScrollBar Lib "user32" (ByVal hwnd As Long, _ ByVal wSBflags As Long, ByVal wArrows As Long) As Long Private Const SB_HORZ = 0 ' barra di scorrimento orizzontale Private Const SB_VERT = 1 ' barra di scorrimento veriticale Private Const SB_CTL = 2 ' controllo Scrollbar Private Const SB_BOTH = 3 ' entrambe le barre Private Private Private Private

Const Const Const Const

ESB_ENABLE_BOTH = &H0 ESB_DISABLE_LTUP = &H1 ESB_DISABLE_RTDN = &H2 ESB_DISABLE_BOTH = &H3

' ' ' '

abilita entrambe le frecce disabilita le frecce verso sinistra/verso l'alto disabilita le frecce verso destra/verso il basso disabilita entrambe le frecce

Private Sub VScroll1_Change() SetScrollbarArrows VScroll1 End Sub Sub SetScrollbarArrows(sbar As Control) Dim barType As Long ' prima riabilita entrambe le frecce EnableScrollBar sbar.hWnd, SB_CTL, ESB_ENABLE_BOTH ' quindi ne disabilita una se necessario If sbar.Value = sbar.Min Then EnableScrollBar sbar.hWnd, SB_CTL, ESB_DISABLE_LTUP ElseIf sbar.Value = sbar.Max Then EnableScrollBar sbar.hWnd, SB_CTL, ESB_DISABLE_RTDN End If End Sub

Verificare che il caret di una TextBox sia visibile  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 Const EM_SCROLLCARET = &HB7 ' assicura che il caret sia visibile. Sub ScrollCaret(tb As TextBox) SendMessage tb.hwnd, EM_SCROLLCARET, 0, ByVal 0& End Sub

Attivare l'interfaccia utente estesa per i controlli ComboBox  Const CB_SETEXTENDEDUI = &H155 Const CB_GETEXTENDEDUI = &H156 Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long ' ottiene lo stato della modalità ExtendedUI ' Esempio: ' MsgBox "ExtendedUI ?: " & GetComboExtendedUIMode(Combo1) Function GetComboExtendedUIMode(ComboCtl As ComboBox) As Boolean GetComboExtendedUIMode = SendMessage(ComboCtl.hwnd, CB_GETEXTENDEDUI, 0, _ ByVal 0) End Function ' determina se abilitare la modalitò ExtendedUI ' ' Esempio: abilita la modalità ExntendedUI ' SetComboExtendedUIMode Combo1, True ' Esempio: disabilita la modalità ExntendedUI ' SetComboExtendedUIMode Combo1, False Function SetComboExtendedUIMode(ComboCtl As ComboBox, ByVal bState As Boolean) SendMessage ComboCtl.hwnd, CB_SETEXTENDEDUI, Abs(bState), ByVal 0 End Function

Ottenere un riferimento ad una form dato il suo nome  ' estrae un riferimento ad una form dato il suo nome ' se vi sono più occorrenze della stessa form, estrae ' la prima che appare nella collezione Forms Function GetForm(ByVal formName As String) As Form Dim frm As Form For Each frm In Forms If StrComp(frm.Name, formName, vbTextCompare) = 0 Then Set GetForm = frm Exit Function End If Next End Function

Implementare la proprietà MaxLength del controllo  ComboBox  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 Const CB_LIMITTEXT = &H141 ' Imposta il numero massimo di caratteri che possono essere immessi in un controllo ComboBox Sub SetComboMaxLength(ComboBox As ComboBox, ByVal lMaxLength As Long) SendMessageLong ComboBox.hWnd, CB_LIMITTEXT, lMaxLength, Byval 0&) End Sub

Ricerche incrementali all'interno dei controlli ListBox  Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal _ hWnd As Long, ByVal msg As Long, ByVal wParam As Long, _ lParam As Any) As Long Const LB_FINDSTRING = &H18F ' questa è una variabile a livello di form Dim DoSearch As Integer Sub List1_Click() ' l'utente ha selezionato un nuovo elemento ' (attivato anche da Text1_KeyDown) Text1.text = List1.text End Sub Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, _ Y As Single) ' mantiene sincronizzati i due controlli Text1.text = List1.text End Sub Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) ' mantiene sincronizzati i due controlli

Text1.text = List1.text End Sub Sub Text1_Change() Static active As Boolean Dim index As Integer Dim search As String Dim found As Integer ' impedisce chiamate ricorsive If active Or DoSearch = False Then Exit Sub active = True ' la ricerca non dipende dalle differenze tra maiuscole e minuscole search = UCase$(Text1.text) found = -1 ' cerca il primo elemento della casella di riepilogo ' che corrisponde alla stringa di ricerca immessa nella casella di testo found = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal search) If found >= 0 Then ' rende il valore trovato l'elemento corrente List1.ListIndex = found Text1.text = List1 ' seleziona i caratteri rimanenti Text1.SelStart = Len(search) Text1.SelLength = 999 End If active = False End Sub Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) If Shift Then ' non fa nulla se viene premuto un tasto Shift ElseIf KeyCode = vbKeyUp Then ' si sposta sull'elemento precedente If List1.ListIndex > 0 Then List1.ListIndex = List1.ListIndex - 1 End If KeyCode = 0 ElseIf KeyCode = vbKeyDown Then ' si sposta sull'elemento successivo If List1.ListIndex < List1.ListCount - 1 Then List1.ListIndex = List1.ListIndex + 1 End If KeyCode = 0 End If End Sub Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = 8 And Text1.SelStart > 0 Then ' se è stato premuto il BackSpace, elimina un carattere dalla ' stringa di ricerca DoSearch = False Text1.text = Left$(Text1.text, Text1.SelStart) Text1.SelStart = Len(Text1.text) Else DoSearch = True End If End Sub

Ottenere l'handle dell'area di modifica di una ComboBox  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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Const GWL_STYLE = (-16) Const ES_UPPERCASE = &H8& Dim editHWnd As Long, style As Long ' ottiene l'handle del controllo Edit interno editHWnd = FindWindowEx(Combo1.hwnd, 0&, vbNullString, vbNullString) ' ottiene la relativa proprietà Style corrente style = GetWindowLong(editHWnd, GWL_STYLE) ' imposta il bit ES_UPPERCASE SetWindowLong editHWnd, GWL_STYLE, style Or ES_UPPERCASE

Rendere a sola lettura un controllo Checkbox  Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Const GWL_STYLE = -16 Const BS_AUTOCHECKBOX = 1 ' rende una casella di controllo di sola lettura (o ne ripristina il ' comportamento standard). ' Non funziona correttamente se la proprietà Style è impostata a 1-Graphical Sub MakeCheckBoxReadOnly(CheckBox As CheckBox, ByVal bReadOnly As Boolean) Dim lStyle As Long lStyle = GetWindowLong(CheckBox.hWnd, GWL_STYLE) If bReadOnly Then lStyle = lStyle Or BS_AUTOCHECKBOX Else lStyle = lStyle And (Not BS_AUTOCHECKBOX) End If SetWindowLong CheckBox.hWnd, GWL_STYLE, lStyle End Sub

Mostrare una form come se fosse disabilitata  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Const GWL_STYLE = (-16) Private Const WS_CHILD = &H40000000 Private Sub Command1_Click() ' imposta il bit WS_CHILD SetWindowLong Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, _ GWL_STYLE) Or WS_CHILD End Sub

Aprire l'elenco a discesa di un controllo ComboBox  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 Const CB_SHOWDROPDOWN = &H14F Const CB_GETDROPPEDSTATE = &H157 ' Mostra o nasconde l'elenco a discesa di una casella combinata Sub ComboBoxOpenList(cbo As ComboBox, Optional showIt As Boolean = True) SendMessage cbo.hwnd, CB_SHOWDROPDOWN, showIt, ByVal 0& End Function ' restituisce True se l'elenco a discesa di una casella combinata è visibile Function ComboBoxIsListVisible(cbo As ComboBox) As Boolean ComboBoxIsListVisible = SendMessage(cbo.hwnd, CB_GETDROPPEDSTATE, 0, _ ByVal 0&) End Function

Attivare la modalità di sovrascrittura per i controlli TextBox  ' variabile a livello di form Dim overwriteMode As Boolean Sub Text1_KeyPress (KeyAscii As Integer) If overwriteMode And KeyAscii >= 32 And Text1.SelLength = 0 Then ' la modalità è quella di sovrascrittura, l'utente non ha premuto nessun ' tasto e non c'è testo evidenziato If Mid$(Text1.Text, Text1.SelStart + 1, 1) <> vbCr Then ' non si è arrivati alla fine della riga di testo corrente ' seleziona il carattere successivo in modo che venga sostituito ' da quello digitato dall'utente finale Text1.SelLength = 1 End If End If End Sub Sub Text1_KeyDown (KeyCode As Integer, Shift As Integer) If KeyCode = 45 And Shift = 0 Then overwriteMode = Not overwriteMode End If End Sub

Rimuovere il comando Close dal menu di sistema  Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, _ ByVal nPosition As Long, ByVal wFlags As Long) As Long

Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As _ Long Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, _ ByVal bRevert As Long) As Long Private Const MF_BYPOSITION = &H400& Private Const MF_REMOVE = &H1000& Private Sub Form_Load() Dim hMenu As Long Dim itemCount As Long ' ottiene l'handle del menu di sistema hMenu = GetSystemMenu(Me.hWnd, 0) ' ottiene il numero di elementi del menu itemCount = GetMenuItemCount(hMenu) ' elimina il commando Close dal menu di sistema RemoveMenu hMenu, itemCount - 1, MF_REMOVE Or MF_BYPOSITION ' elimina la riga di separazione nel menu di sistema RemoveMenu hMenu, itemCount - 2, MF_REMOVE Or MF_BYPOSITION End Sub

Rimuovere i pulsanti Max e Min nelle form MDI  Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hwnd As Long, ByVal nIndex As Long) As Long Const WS_MINIMIZEBOX = &H20000 Const WS_MAXIMIZEBOX = &H10000 Const GWL_STYLE = (-16) Private Sub MDIForm_Load() SetWindowLong Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, _ GWL_STYLE) And Not (WS_MAXIMIZEBOX Or WS_MINIMIZEBOX) End Sub

Salvare e ricaricare le impostazioni di una form dal Registry  ' salva le impostazioni della form Function SaveFormSettings(ByVal AppName As String, frm As Object) SaveSetting AppName, frm.Name, "Left", frm.Left SaveSetting AppName, frm.Name, "Top", frm.Top SaveSetting AppName, frm.Name, "Width", frm.Width SaveSetting AppName, frm.Name, "Height", frm.Height SaveSetting AppName, frm.Name, "WindowState", frm.WindowState End Function ' ripristina le impostazioni della form Function LoadFormSettings(ByVal AppName As String, frm As Object) Dim currWindowState As Integer ' nel caso il Registry non contenga alcun valore On Error Resume Next ' se la form è attualmente minimizzata o massimizzata, riporta lo stato a quello originale, ' altrimenti il comando Move fallisce currWindowState = frm.WindowState If currWindowState <> 0 Then frm.WindowState = 0 ' utilizza un metodo Move per impedire più eventi Resize e Paint frm.Move GetSetting(AppName, frm.Name, "Left", frm.Left), _ GetSetting(AppName, frm.Name, "Top", frm.Top), GetSetting(AppName, _ frm.Name, "Width", frm.Width), GetSetting(AppName, frm.Name, "Height", _ frm.Height) frm.WindowState = GetSetting(AppName, frm.Name, "WindowState", _ currWindowState) End Function ' elimina le impostazioni della form Sub DeleteFormSettings(ByVal AppName As String, frm As Object) DeleteSetting AppName, frm.name End Sub ' ------------- esempio d'uso -------Private Sub Form_Load() LoadFormSettings "MyApp", Me End Sub Private Sub Form_Unload(Cancel As Integer) SaveFormSettings "MyApp", Me End Sub

Mostrare un menu di popup personalizzato per un controllo  TextBox senza ricorrere al subclassing  Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, _ Y As Single) If Button = vbRightButton Then ' disabilita il controllo TextBox Text1.Enabled = False DoEvents ' riabilita il controllo, in modo che non appaia in grigio Text1.Enabled = True ' mostra il menu personalizzato PopupMenu mnuMyPopupMenu End If End Sub

Attirare l'attenzione dell'utente con un titolo lampeggiante  Private Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, _ ByVal bInvert As Long) As Long Private Sub cmdStartFlashing_Click() ' avvia il lampeggio abilitando il timer Timer1.Interval = 1000 End Sub Private Sub cmdStopFlashing_Click() ' disabilita il timer per interrompere il lampeggio e ripristina il titolo originale Timer1.Interval = 0 FlashWindow Me.hWnd, 0 End Sub Private Sub Timer1_Timer() ' modifica lo stato del titolo FlashWindow Me.hWnd, 1 End Sub

Leggere e modificare l'area di formattazione di una TextBox  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 Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Const EM_GETRECT = &HB2 Const EM_SETRECT = &HB3 ' ottiene l'area di formattazione Sub TextBoxGetRect(tb As TextBox, Left As Long, Top As Long, Right As Long, _ Bottom As Long) Dim lpRect As RECT SendMessage tb.hwnd, EM_GETRECT, 0, lpRect Left = lpRect.Left Top = lpRect.Top Right = lpRect.Right Bottom = lpRect.Bottom End Sub ' imposta l'are di formattazione ed esegue il refresh del controllo Sub TextBoxSetRect(tb As TextBox, ByVal Left As Long, ByVal Top As Long, _ ByVal Right As Long, ByVal Bottom As Long) Dim lpRect As RECT lpRect.Left = Left lpRect.Top = Top lpRect.Right = Right lpRect.Bottom = Bottom SendMessage tb.hwnd, EM_SETRECT, 0, lpRect End Sub

Limitare il tipo di caratteri inseriti in un controllo TextBox  Private Declare (ByVal hWnd Private Declare (ByVal hWnd

Function As Long, Function As Long,

GetWindowLong Lib "user32" Alias "GetWindowLongA" _ ByVal nIndex As Long) As Long SetWindowLong Lib "user32" Alias "SetWindowLongA" _ ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Sub ForceTextBoxNumeric(TextBox As TextBox, Optional Force As Boolean = True) Dim style As Long Const GWL_STYLE = (-16) Const ES_NUMBER = &H2000 ' leggi lo stile corrente style = GetWindowLong(TextBox.hWnd, GWL_STYLE) If Force Then style = style Or ES_NUMBER Else style = style And Not ES_NUMBER End If ' applica il nuovo stile SetWindowLong TextBox.hWnd, GWL_STYLE, style End Sub ' modifica lo stile di un TextBox in modo che converta automaticamente ' i caratteri inseriti in minuscolo o maiuscolo ' ConvertCase = 0 => comportamento normale ' ConvertCase = 1 => converti in maiuscolo ' ConvertCase = 2 => converti in minuscolo Sub ForceTextBoxCase(TextBox As TextBox, Optional ConvertCase As Integer) Dim style As Long Const GWL_STYLE = (-16) Const ES_UPPERCASE = &H8& Const ES_LOWERCASE = &H10& ' leggi lo stile corrente style = GetWindowLong(TextBox.hWnd, GWL_STYLE) Select Case ConvertCase Case 0 style = style And Not (ES_UPPERCASE Or ES_LOWERCASE) Case 1 style = style Or ES_UPPERCASE Case 2 style = style Or ES_LOWERCASE End Select ' applica il nuovo stile SetWindowLong TextBox.hWnd, GWL_STYLE, style End Sub

Annullare le modifiche in un controllo TextBox  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 Const EM_CANUNDO = &HC6 Const EM_UNDO = &HC7 Const EM_EMPTYUNDOBUFFER = &HCD Private Sub mnuEdit_Click() If TypeOf ActiveControl Is TextBox Then ' verifica se le modifiche alla casella di testo ' corrente possono essere annullate mnuEditUndo.Enabled = SendMessage(ActiveControl.hWnd, EM_CANUNDO, 0, _ ByVal 0&) Else ' in tutti gli altri casi, disabilita questa voce di menu mnuEditUndo.Enabled = False End If End Sub Private Sub mnuEditUndo_Click() ' annulla le modifiche più recenti apportate al controllo attivo ' (non è necessario utilizzare TypeOf...Is per verificare il tipo di controllo) SendMessage ActiveControl.hWnd, EM_UNDO, 0, ByVal 0& End Sub

Elaborazione intelligente del tasto Tab nelle TextBox multiriga  Sub DisableTabStops(Optional restoreIt As Variant) Static saveTabStop(255) As Boolean Dim index As Integer Dim currForm As Form ' non tutti i controlli espongono la proprietà TabStop On Error Resume Next Set currForm = Screen.ActiveForm If IsMissing(restoreIt) Then restoreIt = False If restoreIt = False Then ' salva il valore corrente della proprietà TabStop ' prima di impostarla a False For index = 0 To currForm.Controls.Count - 1 saveTabStop(index) = currForm.Controls(index).TabStop

currForm.Controls(index).TabStop = False Next Else ' ripristina le impostazioni precedenti For index = 0 To currForm.Count - 1 currForm.Controls(index).TabStop = saveTabStop(index) saveTabStop(index) = False Next End If End Sub Private Sub Text1_GotFocus() ' disabilita la proprietà TabStop per tutti i controlli DisableTabStops End Sub Private Sub Text1_LostFocus() ' ripristina le impostazioni precedenti DisableTabStops True End Sub

Impostare le posizioni dei tabulatori per una TextBox  multiriga  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 Const EM_SETTABSTOPS = &HCB ' imposta i tabulatori in corrispondenza dei caratteri 5, 10 e 20 Dim tabs(2) As Long tabs(0) = 5 * 4 tabs(1) = 10 * 4 tabs(2) = 20 * 4 SendMessage Text1.hWnd, EM_SETTABSTOPS, 3, tabs(0) ' Imposta i tabulatori. Ogni elemento della matrice viene espresso in unità dialog, ' dove ogni unità dialog è pari ad 1/4 della larghezza media del carattere. Sub TextBoxSetTabStops(tb As TextBox, tabStops() As Long) Dim numEls As Long numEls = UBound(tabStops) - LBound(tabStops) + 1 SendMessage tb.hwnd, EM_SETTABSTOPS, numEls, tabStops(LBound(tabStops)) End Sub ' imposta la distanza del tabulatore, espresso in unità dialog Sub TextBoxSetTabStopDistance(tb As TextBox, ByVal distance As Long) SendMessage tb.hwnd, EM_SETTABSTOPS, 1, distance End Sub

Far apparire una finestra in primo piano  Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal _ hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _ ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _ ByVal wFlags As Long) As Long Sub SetTopmostWindow(ByVal hWnd As Long, Optional topmost As Boolean = True) Const HWND_NOTOPMOST = -2 Const HWND_TOPMOST = -1 Const SWP_NOMOVE = &H2 Const SWP_NOSIZE = &H1 SetWindowPos hWnd, IIf(topmost, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, _ SWP_NOMOVE + SWP_NOSIZE End Sub

Creare colonne di dati in un controllo ListBox  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 Const LB_SETTABSTOPS = &H192 ' imposta le posizioni dei tabulatori per un controllo ListBox ' ogni elemento della matrice è espresso in unità dialog, ' dove ogni unità dialog è pari ad 1/4 della larghezza media del carattere. Sub ListBoxSetTabStops(lb As ListBox, tabStops() As Long) Dim numEls As Long numEls = UBound(tabStops) - LBound(tabStops) + 1

SendMessage lb.hwnd, LB_SETTABSTOPS, numEls, tabStops(LBound(tabStops)) End Sub

Trascinare form prive di titolo  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 Declare Sub ReleaseCapture Lib "User32" () Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) Const WM_NCLBUTTONDOWN = &HA1 Const HTCAPTION = 2 If Button = 1 Then ReleaseCapture SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub

Impostare le dimensioni e la posizione di una form  massimizzata  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' Const WM_GETMINMAXINFO = &H24 Private Type POINTAPI X As Long Y As Long End Type Private Type MINMAXINFO ptReserved As POINTAPI ptMaxSize As POINTAPI ptMaxPosition As POINTAPI ptMinTrackSize As POINTAPI ptMaxTrackSize As POINTAPI End Type Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _ source As Any, ByVal numBytes As Long) Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' attiva il subclassing Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) If uMsg = WM_GETMINMAXINFO Then ' Windows chiede alla form le relative ' dimensioni minime e massime e la posizione. Dim mmInfo As MINMAXINFO ' Legge il contenuto della struttura a cui punta lParam. CopyMemory mmInfo, ByVal lParam, Len(mmInfo) With mmInfo ' ptMaxSize sono le dimensioni della form massimizzata .ptMaxSize.X = 600 .ptMaxSize.Y = 400 ' ptMaxPosition è la posizione della form massimizzata .ptMaxPosition.X = ((Screen.Width / Screen.TwipsPerPixelX) - 600) \ _ 2 .ptMaxPosition.Y = ((Screen.Height / Screen.TwipsPerPixelY) - 400) \ _ 2 ' ptMinTrackSize sono le dimensioni minime di una form quando viene ' ridimensionata con il mouse. .ptMinTrackSize.X = 300 .ptMinTrackSize.Y = 200 ' ptMinTrackSize sono le dimensioni massime di una form quando viene ' ridimensionata con il mouse ' (generalmente è uguale a ptMaxSize) .ptMaxTrackSize.X = 600 .ptMaxTrackSize.Y = 400 End With ' copia nella struttura originale in memoria CopyMemory ByVal lParam, mmInfo, Len(mmInfo) ' deve restituire zero per informare che la struttura è stata modificata retValue = 0 End If End Sub

Ottimizzare le procedure Paint con il subclassing  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' la seguente definizione di costante può essere omessa, ' in quanto definita nella type library MsgHook Private Const WM_PAINT = &HF Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function GetUpdateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, _ ByVal bErase As Long) As Long Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) If uMsg = WM_PAINT Then ' Windows chiede alla finestra di ridisegnarsi Dim lpRect As RECT GetUpdateRect Me.hWnd, lpRect, False ' ora lpRect contiene le dimensioni e la posizione (in pixel) ' del rettangolo da aggiornare ' ... ' ... (scrivere qui la procedura per ridisegnare la form) ... ' ... End Select End Sub

Impedire il ripristino di una finestra iconizzata  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' ' la seguente definizione di costante può essere omessa, ' in quanto contenuta nella type library MsgHook Const WM_QUERYOPEN = &H13 Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) If uMsg = WM_QUERYOPEN Then ' la form iconizzata viene ripristinata ' ... ' decommentare la riga successiva per impedire che la form venga ripristinata ' retValue = False End If End Sub

Fornire una breve descrizione della voce di menu che viene  evidenziata  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip Const WM_MENUSELECT = &H11F Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" _ (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, _ ByVal nMaxCount As Long, ByVal wFlag As Long) As Long Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd

End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) If uMsg = WM_MENUSELECT Then ' è stato evidenziato (ma non ancora selezionato) un menu. ' L'identificatore della voce di menu è contenuto nella low word di wParam. ' L'handle del menu è contenuto in lParam Dim menuId As Long, menuCaption As String Dim length As Long, menuDescr As String menuId = (wParam And &HFFFF&) ' ottiene il titolo del menu menuCaption = Space$(256) length = GetMenuString(lParam, menuId, menuCaption, Len(menuCaption), 0) menuCaption = Left$(menuCaption, length) ' confronta la stringa con i titoli di tutte le voci di menu Select Case menuCaption Case "&New" menuDescr = "Create a new file" Case "&Open" menuDescr = "Open an existing file" Case "&Save" menuDescr = "Save a file to disk" Case "E&xit" menuDescr = "Exit the program" End Select ' visualizza la descrizione del menu in un controllo Label lblStatus = menuDescr End If End Sub

Determinare quando l'utente scorre il contenuto di un  controllo TextBox  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' ' le seguenti dichiarazioni di costanti possono essere omesse, ' in quanto sono contenute nella type library MsgHook Const WM_COMMAND = &H111 Const EN_HSCROLL = &H601 Const EN_VSCROLL = &H602 Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) If uMsg = WM_COMMAND Then ' l'utente seleziona una voce di comando da un menu, ' o un controllo invia un messaggio di notifica alla propria form padre, ' o viene utilizzata una sequenza di hot-key ' ' se questo è una notifica da parte di un controllo, lParam contiene il relativo handle. If lParam = Text1.hWnd Then ' In questo caso, il messaggio di notifica è nella ' la high word di wParam. ' NOTA: questo messaggio non arriva se viene utilizzato l'indicatore della barra ' di scorrimento Select Case (wParam \ &H10000) Case EN_HSCROLL ' il controllo TextBox è stato scorso orizzontalmente Case EN_VSCROLL ' il controllo TextBox è stato scorso verticalmente End Select End If End If End Sub

Utilizzare il subclassing per eliminare il menu di popup  predefinito Edit dalle TextBox  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' è possibile omettere la seguente definizione di costante, ' in quanto è contenuta nella type library MsgHook Const WM_CONTEXTMENU = &H7B

Dim WithEvents TextBoxHook As MsgHook Private Sub Form_Load() ' effettua il subclassing del controllo Text1 Set TextBoxHook = New MsgHook TextBoxHook.StartSubclass Text1.hWnd End Sub Private Sub TextBoxHook_BeforeMessage(uMsg As Long, wParam As Long, _ lParam As Long, retValue As Long, Cancel As Boolean) If uMsg = WM_CONTEXTMENU Then ' mostra un menu di popup personalizzato. PopupMenu mnuPopup ' cancella l'elaborazione predefinita ' (ossia non visualizza il menu di contesto predefinito). Cancel = True End If End Sub

Creare controlli TextBox con sfondo retinato  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, _ ByVal nBkMode As Long) As Long Const WM_CTLCOLOREDIT = &H133 Const TRANSPARENT = 1 Dim WithEvents FormHook As MsgHook Dim TextHWnd As Long Private Sub Form_Load() Set FormHook = New MsgHook FormHook.StartSubclass Me TextHWnd = Text1.hWnd End Sub Private Sub FormHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) If uMsg = WM_CTLCOLOREDIT And lParam = TextHWnd Then SetBkMode wParam, TRANSPARENT End If End Sub

Determinare quando l'area di una ComboBox viene chiusa  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip Const WM_COMMAND = &H111 Const CBN_DROPDOWN = 7 Const CBN_CLOSEUP = 8 Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' esegue il subclassing degli eventi della form Set FormHook = New MsgHook ' bisognerebbe passare l'hWnd del contenitore della ComboBox FormHook.StartSubclass Me.hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) Dim Ctrl As Control Dim ctrlIndex As Long Dim cmdCode As Long If uMsg = WM_COMMAND Then ' in entrata, lParam contiene l'hWnd del controllo ' la high word di wParam contiene il codice del comando attuale ' la low word di wParam contiene l'ID del controllo ' (ossia l'indice del controllo nella collezione Controls + 1) ctrlIndex = (wParam And &HFFFF&) - 1 Set Ctrl = Me.Controls(ctrlIndex) cmdCode = (wParam And &HFFFF0000) \ &H10000 If Not TypeOf Ctrl Is ComboBox Then ' questo non dovrebba mai accadere ElseIf cmdCode = CBN_DROPDOWN Then ' l'area dell'elenco viene aperta Debug.Print Ctrl.Name & " is being opened" ElseIf cmdCode = CBN_CLOSEUP Then

' l'area dell'elenco viene chiusa Debug.Print Ctrl.Name & " is being closed" End If End If End Sub

Caselle di testo per l'inserimento della password realmente  sicure  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' Dim WithEvents TextHook As MsgHook Private Sub Form_Load() Set TextHook = New MsgHook ' Text1 è il controllo nel quale viene immessa la password TextHook.StartSubclass Text1 End Sub Private Sub TextHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) ' filtra il messaggio WM_GETTEXT If uMsg = WM_GETTEXT Then Cancel = True End Sub

Creare form non rettangolari  Type POINTAPI X As Long Y As Long End Type Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, _ ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, _ ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, _ ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, _ ByVal Y3 As Long) As Long Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, _ ByVal hRgn As Long, ByVal bRedraw As Long) As Long Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Sub SetWindowShape(ByVal hWnd As Long, ByVal Shape As Long) Dim lpRect As RECT Dim wi As Long, he As Long Dim hRgn As Long ' leggi le dimensioni del form in pixel GetWindowRect hWnd, lpRect wi = lpRect.Right - lpRect.Left he = lpRect.Bottom - lpRect.Top ' crea una regione Select Case Shape Case 0 ' cerchio o ellisse hRgn = CreateEllipticRgn(0, 0, wi, he) Case 1 ' rettangolo arrotondato hRgn = CreateRoundRectRgn(0, 0, wi, he, 20, 20) Case 2 ' rombo Dim lpPoints(3) As POINTAPI lpPoints(0).X = wi \ 2 lpPoints(0).Y = 0 lpPoints(1).X = 0 lpPoints(1).Y = he \ 2 lpPoints(2).X = wi \ 2 lpPoints(2).Y = he lpPoints(3).X = wi lpPoints(3).Y = he \ 2 hRgn = CreatePolygonRgn(lpPoints(0), 4, 1) End Select ' applica la regione alle form SetWindowRgn hWnd, hRgn, True DeleteObject hRgn End Sub

Private Sub Form_Load() ' mostra il form con i bordi arrotondato SetWindowShape Me.hWnd, 1 End Sub

Capitolo 6 - Altri controlli Scaricare e salvare una pagina HTML con l'Internet Transfer  Control  ' ' ' ' '

restituisce il contenuto di una pagina HTML ad un determinato URL ed eventualmente lo salva in un file utilizza un Internet Transfer Control, che deve essere passato come primo argomento

Function GetHTMLPage(INet As INet, ByVal URL As String, _ Optional FileName As String) As String Dim fnum As Integer ' annulla qualsiasi operazione in sospeso INet.Cancel ' imposta il protocollo ad HTTP INet.Protocol = icHTTP ' ottiene la pagina GetHTMLPage = INet.OpenURL(URL) ' salva in un file, se richiesto If FileName <> "" Then fnum = FreeFile Open FileName For Output As #fnum Print #fnum, GetHTMLPage; Close #fnum End If End Function

Determinare il numero di elementi visibili in un controllo  ListView  Private Const LVM_FIRST = &H1000 Private Const LVM_GETCOUNTPERPAGE = (LVM_FIRST + 40) 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 ' Restituisce il numero di elementi visibili in un controllo ListView Private Function ListViewGetVisibleCount(LV As ListView) As Long ListViewGetVisibleCount = SendMessage(LV.hwnd, LVM_GETCOUNTPERPAGE, 0&, _ ByVal 0&) End Function

Ottenere o impostare l'altezza dei nodi di un controllo  TreeView  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 TV_FIRST = &H1100 Private Const TVM_SETITEMHEIGHT = (TV_FIRST + 27) Private Const TVM_GETITEMHEIGHT = (TV_FIRST + 28) ' restituisce l'altezza dei singoli elementi di un TreeView NodeHeight = SendMessage(TreeView1.hWnd, TVM_GETITEMHEIGHT, 0, ByVal 0&) ' imposta l'altezza dei singoli elementi di un TreeView ' utilizza il valore -1 per ripristinare l'altezza predefinita SendMessage TreeView1.hWnd, TVM_SETITEMHEIGHT, newNodeHeight, ByVal 0&

Riempire un controllo TreeView con dati casuali  ' MaxChildren è il numero Massimo di nodi figlio ad ogni livello ' MaxLevel è il livello massimo di annidamento che si vuole creare Sub AddRandomNodes(TV As TreeView, Node As Node, MaxChildren As Integer, _ MaxLevel As Integer) Dim i As Integer Dim child As Node ' Aggiunge un numero di nodi figlio minore o uguale a MaxChildren

For i = 1 To CInt(Rnd * MaxChildren) Set child = TV.Nodes.Add(Node.index, tvwChild, , _ "Node #" & (TV.Nodes.Count + 1)) ' per ogni nodi figlio, se MaxLevel è maggiore di 0 ' aggiunge casualmente un insieme di nodi figlio If CInt(Rnd * MaxLevel) Then AddRandomNodes TV, child, MaxChildren, MaxLevel - 1 End If Next End Sub

Eliminare i tooltip del controllo TreeView  Private Declare (ByVal hwnd Private Declare (ByVal hwnd

Function As Long, Function As Long,

SetWindowLong Lib "user32" Alias "SetWindowLongA" _ ByVal nIndex As Long, ByVal dwNewLong As Long) As Long GetWindowLong Lib "user32" Alias "GetWindowLongA" _ ByVal nIndex As Long) As Long

Const TVS_NOTOOLTIPS = &H80 Const GWL_STYLE = (-16) ' disattiva i tooltip SetWindowLong TreeView1.hwnd, GWL_STYLE, GetWindowLong(TreeView1.hwnd, _ GWL_STYLE) Or TVS_NOTOOLTIPS ' attiva i tooltip SetWindowLong TreeView1.hwnd, GWL_STYLE, GetWindowLong(TreeView1.hwnd, _ GWL_STYLE) And (Not TVS_NOTOOLTIPS)

Inserire un'immagine in un controllo RichTextBox  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 WM_PASTE = &H302 Sub InsertPictureInRichTextBox(RTB As RichTextBox, Picture As StdPicture) ' copia l'immagine nella Clipboard. Clipboard.Clear Clipboard.SetData Picture ' incolla nel controllo RichTextBox SendMessage RTB.hwnd, WM_PASTE, 0, 0 End Sub

Limitare la lunghezza di un elemento di un controllo 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 Const LVM_FIRST = &H1000 Const LVM_GETEDITCONTROL = (LVM_FIRST + 24) Const EM_LIMITTEXT = &HC5 ' limita a 10 caratteri il testo che può essere immesso in un elemento di un ListView Private Sub ListView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del ListView editHWnd = SendMessage(ListView1.hWnd, LVM_GETEDITCONTROL, 0, ByVal 0&) ' gli invia un messaggio EM_LIMITTEXT per limitarne la lunghezza SendMessage editHWnd, EM_LIMITTEXT, 10, 0 End Sub ' ------- secondo esempio 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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Const GWL_STYLE = (-16) Const LVM_FIRST = &H1000 Const LVM_GETEDITCONTROL = (LVM_FIRST + 24) Const ES_UPPERCASE = &H8& ' converte in maiuscolo tutto il testo digitato in un nodo di un ListView Private Sub ListView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del ListView editHWnd = SendMessage(ListView1.hWnd, LVM_GETEDITCONTROL, 0, ByVal 0&) ' applica lo stile "tutto in maiuscolo"

SetWindowLong editHWnd, GWL_STYLE, GetWindowLong(editHWnd, _ GWL_STYLE) Or ES_UPPERCASE End Sub

Leggere e impostare il primo nodo visibile in un controllo  TreeView  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 TV_FIRST = &H1100 Private Const TVM_GETNEXTITEM = (TV_FIRST + 10) Private Const TVM_SELECTITEM = (TV_FIRST + 11) Private Const TVGN_CARET = 9 Private Const TVGN_FIRSTVISIBLE = &H5 ' restituisce il primo Node visibile in un TreeView Function GetTreeViewFirstVisibleNode(ByVal TV As TreeView) As Node Dim hItem As Long Dim selNode As Node ' ricorda quale node è selezionato Set selNode = TV.SelectedItem ' ottieni l'handle del primo nodo visibile usando le API hItem = SendMessage(TV.hWnd, TVM_GETNEXTITEM, TVGN_FIRSTVISIBLE, ByVal 0&) ' rendilo il node selezionato SendMessage TV.hWnd, TVM_SELECTITEM, TVGN_CARET, ByVal hItem ' imposta il risultato leggendo la proprietà SelectedItem Set GetTreeViewFirstVisibleNode = TV.SelectedItem ' ripristina il nodo precedentemente selezionato Set TV.SelectedItem = selNode End Function

' imposta il primo nodo visibile in un TreeView Sub SetTreeViewFirstVisibleNode(ByVal TV As TreeView, ByVal Node As Node) Dim hItem As Long Dim selNode As Node ' ricorda quale node è selezionato Set selNode = TV.SelectedItem ' rendi il nodo prescelto il nodo selezionato Set TV.SelectedItem = Node ' ora possiamo leggere il suo handle hItem = SendMessage(TV.hWnd, TVM_GETNEXTITEM, TVGN_CARET, ByVal 0&) ' ripristina il nodo precedentemente selezionato Set TV.SelectedItem = selNode ' rendi il nodo passato come argomento il primo visibile nel controllo SendMessage TV.hWnd, TVM_SELECTITEM, TVGN_FIRSTVISIBLE, ByVal hItem End Sub

Limitare la lunghezza del testo in un nodo di un TreeView  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 Const TV_FIRST = &H1100 Const TVM_GETEDITCONTROL = TV_FIRST + 15 Const EM_LIMITTEXT = &HC5 ' Limita a 20 caratteri il testo che può essere immesso in un nodo di TreeView1 Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del TreeView editHWnd = SendMessage(TreeView1.hWnd, TVM_GETEDITCONTROL, 0, ByVal 0&) ' gli invia un messaggio EM_LIMITTEXT per limitarne la lunghezza SendMessage editHWnd, EM_LIMITTEXT, 20, 0 End Sub ' -------- secondo esempio ----------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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Const GWL_STYLE = (-16) Const TV_FIRST = &H1100 Const TVM_GETEDITCONTROL = TV_FIRST + 15 Const ES_UPPERCASE = &H8&

' converte in maiuscolo il testo digitato in un nodo di un TreeView Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del TreeView editHWnd = SendMessage(TreeView1.hWnd, TVM_GETEDITCONTROL, 0, ByVal 0&) ' applica lo stile "tutto in maiuscolo" SetWindowLong editHWnd, GWL_STYLE, GetWindowLong(editHWnd, _ GWL_STYLE) Or ES_UPPERCASE End Sub

Ottenere il testo puro o in formato HTML del contenuto di un  controllo WebBrowser  Sub SaveWebBrowser(WB As WebBrowser, ByVal FileName As String, _ Optional SaveAsPlainText As Boolean) Dim Text As String, fnum As Integer If SaveAsPlainText Then Text = BW.Document.Body.innerHTML Else Text = BW.Document.documentElement.O BW.Document.documentElement.OuterHTML uterHTML End If ' salva in un file fnum = FreeFile Open FileName For Output As #fnum Print #fnum, Text; Close #fnum End Sub

Ottenere il pieno controllo sul testo inserito in un elemento di  un ListView  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip 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 Const LVM_FIRST = &H1000 Const LVM_GETEDITCONTROL = (LVM_FIRST + 24) Dim WithEvents TVHook As MsgHook ' inizia il subclassing del controllo Edit utilizzato in modalità di modifica Private Sub ListView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del TreeView editHWnd = SendMessage(ListView1.hWnd, LVM_GETEDITCONTROL, 0, ByVal 0&) ' esegue il subclassing LVHook.StartSubclass editHWnd End Sub ' interrompe il subclassing quando esce dalla modalità di modifica Private Sub ListView1_AfterLabelEdit(Cancel As Integer, NewString As String) LVHook.StopSubclass End Sub Private Sub Form_Load() Set LVHook = New MsgHook End Sub ' elimina le cifre non appena vengono immesse dall'utente ' e converte tutto il testo in maiuscolo Private Sub LVHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) If uMsg = WM_CHAR Then ' wParam contiene il codice dei caratteri If wParam >= 48 And wParam <= 57 Then ' elimina le cifre Cancel = True ElseIf wParam >= Asc("a") And wParam <= Asc("z") Then ' converte in maiuscolo wParam = wParam - 32 End If End If End Sub

Ottenere il pieno controllo sul testo inserito in un nodo di un  TreeView  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip 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 TV_FIRST = &H1100 Private Const TVM_GETEDITCONTROL = TV_FIRST + 15 Dim WithEvents TVHook As MsgHook ' inizia il subclassing del controllo Edit utilizzato in modalità di modifica Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer) Dim editHWnd As Long ' ottiene l'handle del controllo Edit del TreeView editHWnd = SendMessage(TreeView1.hWnd, TVM_GETEDITCONTROL, 0, ByVal 0&) ' esegue il subclassing TVHook.StartSubclass editHWnd End Sub Private Sub TreeView1_AfterLabelEdit(Cancel As Integer, NewString As String) ' interrompe il subclassing quando esce dalla modalità di modifica TVHook.StopSubclass End Sub Private Sub Form_Load() ' crea un'istanza del controllo che esegue il subclassing Set TVHook = New MsgHook End Sub ' elimina gli spazi non appena vengono immessi dall'utente Private Sub TVHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) If uMsg = WM_CHAR Then ' wParam contiene il codice del carattere If wParam = 32 Then Cancel = True End If End Sub

Impedire il trascinamento degli elementi di un controllo  ListView  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip Const WM_NOTIFY = &H4E Const LVN_FIRST = -100& Const LVN_BEGINDRAG = (LVN_FIRST - 9) Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) Private Type NMHDR hwndFrom As Long idFrom As Long code As Long End Type Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing della form corrente Set FormHook = New MsgHook FormHook.StartSubclass Me ' popola il controllo ListView1 con i dati ' ... (omesso) ... End Sub ' questo evento viene scatenato quando alla form si invia un messaggio Private Sub FormHook_BeforeMessage(uMsg As Long, wParam As Long, lParam As Long, _ retValue As Long, Cancel As Boolean) ' il ListView notifica qualcosa alla propria form padre If uMsg = WM_NOTIFY Then ' copia la struttura MNHDR a cui punta ' lParam in un UDT locale Dim nmh As NMHDR

CopyMemory nmh, ByVal lParam, Len(nmh) ' controlla se la notifica arriva dal controllo ListView1 ' e se si è all'inizio dell'operazione di trascinamento If nmh.hwndFrom = ListView1.hWnd And nmh.code = LVN_BEGINDRAG Then ' sì, cancella l'operazione retValue = 1 Cancel = True End If End If End Sub

Capitolo 7 - Grafica e Stampa Visualizzare una GIF animata utilizzando il controllo  WebBrowser  Private Declare Function GetSystemMetrics Lib "user32" Alias "GetSystemMetrics" _ (ByVal nIndex As Long) As Long Private Const SM_CXVSCROLL = 2 Private Const SM_CYHSCROLL = 3 ' crea una nuova PictureBox Dim picBox As PictureBox Set picBox = Controls.Add("VB.PictureBox", "picBox") ' ridimensiona la PictureBox in modo che nasconda ' le barre di scorrimento del controllo WebBrowser With WebBrowser1 picBox.Move .Left, .Top, .Width - ScaleX(GetSystemMetrics(SM_CXVSCROLL), _ vbPixels), .Height - ScaleY(GetSystemMetrics(SM_CYHSCROLL), vbPixels) ' sposta il WebBrowser all'interno della PictureBox Set WebBrowser1.Container = picBox ' controlla che il bordo del controllo WebBrowser non sia visibile .Move -ScaleX(2, vbPixels), -ScaleY(2, vbPixels) End With ' tutti i controlli vengono creati invisibili picBox.Visible = True

Verificare sempre che una stampante sia installata  Function PrinterIsInstalled() As Boolean Dim dummy As String On Error Resume Next dummy = Printer.DeviceName If Err.Number Then MsgBox "No default printer installed." & vbCrLf & _ "To install and select a default printer, select the " & _ "Setting / Printers command in the Start menu, and then " & _ "double-click on the Add Printer icon.", vbExclamation, _ "Printer Error" PrinterIsInstalled = False Else PrinterIsInstalled = True End If End Function

Estrarre le componenti Red, Green, Blue di un colore  Function GetRed(ByVal lColor As Long) As Long GetRed = lColor Mod 256 End Function Function GetGreen(ByVal lColor As Long) As Long GetGreen = (lColor \ &H100) Mod 256 End Function Function GetBlue(ByVal lColor As Long) As Long GetBlue = (lColor \ &H10000) Mod 256 End Function

Impostare il colore di un pixel  Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, _ ByVal y As Long) As Long Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, _ ByVal y As Long, ByVal crColor As Long) As Long Private Sub Form_Click() Dim x As Long, y As Long, h As Long h = Me.hdc ' assume che la ScaleMode della form ' sia impostata a 3 - Pixels For y = 0 To ScaleHeight - 1 For x = 0 To ScaleWidth - 1 If GetPixel(h, x, y) = vbRed Then SetPixel h, x, y, vbYellow End If Next

Next End Sub

Modificare il colore dei pixel in un'area  Private Declare Function ExtFloodFill Lib "GDI32" (ByVal hDC As Long, _ ByVal X As Long, ByVal Y As Long, ByVal colorCode As Long, _ ByVal fillType As Long) As Long Const FLOODFILLBORDER = 0 Const FLOODFILLSURFACE = 1 Sub AreaFill(obj As Object, ByVal X As Long, ByVal Y As Long, _ ByVal colorCode As Long, Optional borderColor As Variant) Dim x2 As Long, y2 As Long Dim saveFillStyle As Long Dim saveFillColor As Long With obj ' converte le coordinate in pixel x2 = .ScaleX(X, .ScaleMode, vbPixels) y2 = .ScaleY(Y, .ScaleMode, vbPixels) ' salva le proprietà FillStyle e FillColor saveFillStyle = .FillStyle saveFillColor = .FillColor ' imposta valori opportuni per queste proprietà .FillStyle = 0 .FillColor = colorCode If IsMissing(borderColor) Then ' leggi il colore alle coordinate date borderColor = .Point(X, Y) ' modifica tutti i pixel di quel colore ExtFloodFill .hDC, x2, y2, borderColor, FLOODFILLSURFACE Else ' modifica tutti i pixel fino ad incontrare il bordo ExtFloodFill .hDC, x2, y2, borderColor, FLOODFILLBORDER End If ' ripristina le proprietà .FillStyle = saveFillStyle .FillColor = saveFillColor End With End Sub

Convertire il valore di un colore in toni di grigio  Function GetGreyScale(ByVal lColor As Long) lColor = 0.33 * (lColor Mod 256) + 0.59 * ((lColor \ 256) Mod 256) + 0.11 * _ ((lColor \ 65536) Mod 256) GetGreyScale = RGB(lColor, lColor, lColor) End Function

Ottenere le proprietà dei Bitmap  Private Type BITMAP bmType As Long ' questo deve essere zero bmWidth As Long ' larghezza del bitmap bmHeight As Long ' altezza del bitmap bmWidthBytes As Long ' byte nella linea raster orizzontale bmPlanes As Integer ' numero dei piani di colore bmBitsPixel As Integer ' numero di bit per pixel bmBits As Long ' indirizzo dei pixel di dati in memoria End Type Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal _ hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Sub GetBitmapInfo(ByVal handle As Long, width As Long, height As Long, _ Optional colorPlanes As Long, Optional bitsPerPixel As Long ) Dim bmp As BITMAP GetObjectAPI handle, Len(bmp), bmp width = bmp.bmWidth height = bmp.bmHeight colorPlanes = bmp.bmPlanes bitsPerPixel = bmp.bmBitsPixel End Sub ' ------- esempio GetBitmapInfo Picture1.Picture, width, height, colorPlanes, bitsPerPixel Label1 = "Width = " & width & vbCrLf & "Height = " & height & vbCrLf & _ "Color Planes = " & colorPlanes & vbCrLf & "Bits per Pixel = " & _ bitsPerPixel

Copiare il contenuto dello schermo o della finestra attiva  Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Const KEYEVENTF_KEYUP = &H2 ' ' ' ' ' ' '

Restituisce il contenuto corrente dello schermo o della finestra attiva Funziona simulando la pressione del tasto Print-Screen (e del tasto Alt se ActiveWindow è True) che immette il contenuto dello schermo nella Clipboard. Il contenuto originale della Clipboard viene quindi ripristinato ma questa azione potrebbe influenzare il comportamento di altre applicazioni che effettuano il monitoraggio della Clipboard.

Function GetScreenBitmap(Optional ActiveWindow As Boolean) As Picture ' salva l'immagine corrente nella Clipboard, se c'è Dim pic As StdPicture Set pic = Clipboard.GetData(vbCFBitmap) ' Alt-Print Screen cattura solamente il contenuto della finestra attiva If ActiveWindow Then ' Preme il tasto Alt keybd_event vbKeyMenu, 0, 0, 0 End If ' Preme il tasto Print Screen keybd_event vbKeySnapshot, 0, 0, 0 DoEvents ' Rilascia il tasto Print Screen keybd_event vbKeySnapshot, 0, KEYEVENTF_KEYUP, 0 If ActiveWindow Then ' Rilascia il tasto Alt keybd_event vbKeyMenu, 0, KEYEVENTF_KEYUP, 0 End If DoEvents ' restituisce il bitmap attualmente nella Clipboard Set GetScreenBitmap = Clipboard.GetData(vbCFBitmap) ' ripristina il contenuto originale della Clipboard Clipboard.SetData pic, vbCFBitmap End Function

Capitolo 8 - Tastiera e Mouse Determinare il numero dei pulsanti del mouse  Const SM_CMOUSEBUTTONS = 43 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) _ As Long Function GetNumMouseButtons() As Long GetNumMouseButtons = GetSystemMetrics(SM_CMOUSEBUTTONS) End Function Private Command1_Click() MsgBox "Your mouse has " & GetNumMouseButtons & " buttons." End Sub

Determinare lo stato dei pulsanti del mouse  Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As _ Integer Function LeftButton() As Boolean LeftButton = (GetAsyncKeyState(vbKeyLButton) And &H8000) End Function Function RightButton() As Boolean RightButton = (GetAsyncKeyState(vbKeyRButton) And &H8000) End Function Function MiddleButton() As Boolean MiddleButton = (GetAsyncKeyState(vbKeyMButton) And &H8000) End Function Function MouseButton() As Integer If GetAsyncKeyState(vbKeyLButton) < 0 Then MouseButton = 1 End If If GetAsyncKeyState(vbKeyRButton) < 0 Then MouseButton = MouseButton Or 2 End If If GetAsyncKeyState(vbKeyMButton) < 0 Then MouseButton = MouseButton Or 4 End If End Function

Leggere lo stato dei tasti Shift  Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As _ Integer ' Lo stato del tasto Ctrl Function CtrlKey() As Boolean CtrlKey = (GetAsyncKeyState(vbKeyControl) And &H8000) End Function ' Lo stato di entrambi i tasti Shift Function ShiftKey() As Boolean ShiftKey = (GetAsyncKeyState(vbKeyShift) And &H8000) End Function ' Lo stato del tasto Alt Function AltKey() As Boolean AltKey = (GetAsyncKeyState(vbKeyMenu) And &H8000) End Function

Leggere la posizione del mouse  Private Type POINTAPI X As Long Y As Long End Type Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, _ lpPoint As POINTAPI) As Long Function MouseX(Optional ByVal hWnd As Long) As Long Dim lpPoint As POINTAPI GetCursorPos lpPoint If hWnd Then ScreenToClient hWnd, lpPoint MouseX = lpPoint.X End Function

Function MouseY(Optional ByVal hWnd As Long) As Long Dim lpPoint As POINTAPI GetCursorPos lpPoint If hWnd Then ScreenToClient hWnd, lpPoint MouseY = lpPoint.Y End Function

Spostare il mouse al centro di una form o controllo  Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Sub SnapMouseToWindow(ByVal hWnd As Long) Dim lpRect As RECT ' ottieni le coordinate della form/controllo in pixel GetWindowRect hWnd, lpRect ' sposta il cursore del mouse al suo centro SetCursorPos lpRect.Left + (lpRect.Right - lpRect.Left) \ 2, _ lpRect.Top + (lpRect.Bottom - lpRect.Top) \ 2 End Sub

Ripristinare correttamente il cursore del mouse  ' la classe CMouseCursor Private oldMousePointer As Variant ' imposta un nuovo cursore Sub SetCursor(Optional NewCursor As MousePointerConstants = vbHourGlass) If IsEmpty(oldMousePointer) Then ' salva il cursore originale, ma solo la prima volta ' che il metodo viene invocato su questa istanza oldMousePointer = Screen.MousePointer End If Screen.MousePointer = NewCursor End Sub Private Sub Class_Terminate() ' ripristina il cursore originale, se è stato modificato If Not IsEmpty(oldMousePointer) Then Screen.MousePointer = oldMousePointer End If End Sub

Simulare gli eventi MouseEnter e MouseExit  Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function GetCapture Lib "user32" () As Long Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) If (X < 0) Or (Y < 0) Or (X > Command1.Width) Or (Y > Command1.Height) Then ' lo pseudo-evento MOUSELEAVE ReleaseCapture ' in questo esempio riporta il titolo allo stile normale Command1.Font.Bold = False ElseIf GetCapture() <> Command1.hwnd Then ' lo pseudo-evento MOUSEENTER SetCapture Command1.hwnd ' in questo esempio, trasforma il titolo in grassetto Command1.Font.Bold = True End If End Sub Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) If (X Or Y) < 0 Or (X > Text1.Width) Or (Y > Text1.Height) Then ReleaseCapture Text1.SelLength = 0 ElseIf GetCapture() <> Text1.hWnd Then SetCapture Text1.hWnd Text1.SelStart = 0 Text1.SelLength = Len(Text1) Text1.SetFocus End If End Sub

Leggere lo stato dei tasti di lock  Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long ' leggi lo stato corrente del tasto CapsLock Function GetCapsLockKey() As Boolean GetCapsLockKey = GetKeyState(vbKeyCapital) End Function ' leggi lo stato corrente del tasto NumLock Function GetNumLockKey() As Boolean GetNumLockKey = GetKeyState(vbKeyNumlock) End Function ' leggi lo stato corrente del tasto ScrollLock Function GetScrollLockKey() As Boolean GetScrollLockKey = GetKeyState(vbKeyScrollLock) End Function

Modificare lo stato dei tasti di lock  Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As _ Long ' imposta lo stato del tasto CapsLock Sub SetCapsLockKey(ByVal newState As Boolean) Const KEYEVENTF_KEYUP = &H2 ' se lo stato corrente deve essere modificato If CBool(GetKeyState(vbKeyCapital)) <> newState Then ' premi e rilascia il tasto CapsLock via codice keybd_event vbKeyCapital, 0, 0, 0 keybd_event vbKeyCapital, 0, KEYEVENTF_KEYUP, 0 End If End Sub ' imposta lo stato del tasto NumLock Sub SetNumLockKey(ByVal newState As Boolean) Const KEYEVENTF_KEYUP = &H2 ' se lo stato corrente deve essere modificato If CBool(GetKeyState(vbKeyNumlock)) <> newState Then ' premi e rilascia il tasto NumLock via codice keybd_event vbKeyNumlock, 0, 0, 0 keybd_event vbKeyNumlock, 0, KEYEVENTF_KEYUP, 0 End If End Sub ' imposta lo stato del tasto ScrollLock Sub SetScrollLockKey(ByVal newState As Boolean) Const KEYEVENTF_KEYUP = &H2 ' se lo stato corrente deve essere modificato If CBool(GetKeyState(vbKeyScrollLock)) <> newState Then ' premi e rilascia il tasto ScrollLock via codice keybd_event vbKeyScrollLock, 0, 0, 0 keybd_event vbKeyScrollLock, 0, KEYEVENTF_KEYUP, 0 End If End Sub

Capitolo 9 - File e directory Caricare un file di testo in un'unica operazione  Function FileText (filename$) As String Dim handle As Integer handle = FreeFile Open filename$ For Input As #handle FileText = Input$(LOF(handle), handle) Close #handle End Function Function FileText(ByVal filename As String) As String Dim handle As Integer ' controlla che il file esista If Len(Dir$(filename)) = 0 Then Err.Raise 53 ' file non trovato End If ' lo apre in modalità binaria handle = FreeFile Open filename$ For Binary As #handle ' legge la stringa e chiude il file FileText = Space$(LOF(handle)) Get #handle, , FileText Close #handle End Function

Controllare che un file o una directory esista  Function FileExists(FileName As String) As Boolean On Error Resume Next ' leggi l'attributo assicurati che non sia una directory FileExists = (GetAttr(FileName) And vbDirectory) = 0 ' se avviene un errore la routine restituisce False End Function Function DirExists(DirName As String) As Boolean On Error Resume Next ' leggi l'attributo assicurati che non sia un file DirExists = GetAttr(DirName) And vbDirectory ' se avviene un errore la routine restituisce False End Function

Ottenere informazioni su tutti i drive disponibili  ' NOTA: questo codice richiede un riferimento alla type library ' Microsoft Scripting Runtime Dim fso As New Scripting.FileSystemObject Dim drv As Scripting.Drive Dim info As String For Each drv In fso.Drives ' visualizza il nome ed il tipo di drive info = "Drive " & drv.DriveLetter & vbCrLf info = info & " Type: " ' è necessario decodificare questo valore Select Case drv.DriveType Case Removable: info = info & "Removable" & vbCrLf Case Fixed: info = info & "Fixed" & vbCrLf Case CDRom: info = info & "CDRom" & vbCrLf Case Remote: info = info & "Remote" & vbCrLf Case RamDisk: info = info & "RamDisk" & vbCrLf Case Else: info = info & "Unknown" & vbCrLf End Select If Not drv.IsReady Then ' se il drive non è pronto non è possibile fare molto di più info = info & " Not Ready" & vbCrLf Else ' estrae tutte le informazioni aggiuntive info = info & " File System: " & drv.FileSystem & vbCrLf info = info & " Label: " & drv.VolumeName & vbCrLf info = info & " Serial number: " & drv.SerialNumber & vbCrLf info = info & " Total space: " & drv.TotalSize & vbCrLf info = info & " Free space: " & drv.FreeSpace & vbCrLf End If

' esegue qualcosa con le informazioni ottenute ' (in questo caso le visualizza in una casella di testo) Text1.Text = Text1.Text & info Next

Contare i caratteri in un file  Sub CountFileCharacters(filename As String, charCount() As Long) Dim filenum As Integer Dim index As Long, acode As Integer On Error Resume Next filenum = FreeFile() Open filename For Binary As #filenum ' legge il contenuto del file in una matrice di Byte temporanea ReDim bArr(0 To LOF(filenum)) As Byte Get #filenum, , bArr() Close #filenum ' analizza la matrice, aggiorna charCount() For index = 0 To UBound(bArr) acode = bArr(index) charCount(acode) = charCount(acode) + 1 Next End Sub

Cercare un file in un albero di directory utilizzando la DLL Imagehlp  Private Declare Function SearchTreeForFile Lib "imagehlp.dll" (ByVal sRootPath _ As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) _ As Boolean ' ' ' ' ' ' ' '

cerca un file in un albero di sottodirectory restituisce il percorso+nome completo di filename oppure una stringa nulla se filename non è stato trovato viene restituita solo la prima occorrenza del file ROOTDIR può essere la directory radice di un drive (ad esempio, "C:\") o una sottodirectory ("C:\DOCS")

Function SearchFileInDirTree(ByVal rootDir As String, ByVal Filename As String) _ As String ' questa è la lunghezza massima per filename Dim buffer As String * 260 On Error Goto Unsupported If SearchTreeForFile(rootDir, Filename, buffer) Then ' un valore di ritorno diverso da zero significa successo SearchFileInDirTree = Left$(buffer, InStr(buffer, vbNullChar) - 1) End If Exit Sub Unsupported: ' non tutte le versioni di Windows supportano questa funzione MsgBox "SearchTreeForFile non supportata su questo sistema" End Function

Convertire nomi lunghi di file nel formato 8.3 e viceversa  Private Declare Function GetShortPathName Lib "kernel32" Alias _ "GetShortPathNameA" (ByVal lpszLongPath As String, _ ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Const MAX_PATH = 260 Public Function ShortPathName(ByVal FileName As String) As String Dim length As Long, res As String res = String$(MAX_PATH, 0) length = GetShortPathName(FileName, res, Len(res)) If length Then ShortPathName = Left$(res, length) End If End Function Private Declare Function GetLongPathName Lib "kernel32" Alias _ "GetLongPathNameA" (ByVal lpszShortPath As String, _ ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long Const MAX_PATH = 260 Public Function LongPathName(ByVal FileName As String) As String Dim length As Long, res As String On Error Resume Next

res = String$(MAX_PATH, 0) length = GetLongPathName(FileName, res, Len(res)) If length And Err = 0 Then LongPathName = Left$(res, length) End If End Function

Determinare se una directory è condivisa  Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type Public Const SHGFI_ATTRIBUTES = &H800 Public Const SFGAO_SHARE = &H20000 Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _ ( ByVal pszPath As String, ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long Function IsFolderShared(ByVal folderName As String) As Boolean Dim sfi As SHFILEINFO SHGetFileInfo foldernName, 0, sfi, Len(sfi), SHGFI_ATTRIBUTES IsFolderShared = (sfi.dwAttributes And SFGAO_SHARE) End Function

Formattare un drive utilizzando una funzione non  documentata  Private Declare Function SHFormatDrive Lib "Shell32.dll" (ByVal hWnd As Long, _ ByVal Drive As Integer, ByVal fmtID As Integer, ByVal Options As Integer) _ As Long Private Sub btnFormatDrive_Click() Dim ret As Long ' formattazione completa di A: ret = SHFormatDrive(Me.hWnd, 0,-1, 1) Select Case ret Case -1 MsgBox "Error during format operation" Case -2 MsgBox "Operation canceled by user" Case -3 MsgBox "This drive cannot be formatted" Case Else MsgBox "Done" End Select End Sub

Capitolo 10 - Programmazione ad oggetti Implementare proprietà Variant che possono contenere  oggetti  ' alla proprietà Tag può essere assegnato sia un oggetto ' sia un valore di altro tipo Dim m_Tag As Variant Property Get Tag() As Variant If IsObject(m_Tag) Then Set Tag = m_Tag Else Tag = m_Tag End If End Property ' questa procedura viene invocata quando si assegna ' un oggetto alla proprietà Tag Property Set Tag(newValue As Variant) Set m_Tag = newValue End Property ' questa procedura viene invocata quando si assegna ' un valore di altro tipo alla proprietà Tag Property Let Tag(newValue As Variant) m_Tag = newValue End Property

Un template per creare moduli di classe di tipo collection  VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "CollectionClassName" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '---------------------------------------------------' Un template per le classi Collection '---------------------------------------------------' ' Cosa fare dopo aver aggiunto questo template ' al programma corrente: ' ' 1) modificare il nome della classe a seconda delle necessità ' 2) utilizzare il comando "search and replace" per sostituire tutte le ' istanze di "BaseClassName" (senza virgolette) con il nome effettivo ' della classe di base ' 3) modificare eventualmente il metodo ADD in modo da inizializzare ' le proprietà dell'oggetto NEWITEM prima di aggiungerlo ' alla collezione privata ' 4) eliminare questi commenti '-----------------------------------------------------Option Explicit ' La collezione privata utilizzata per contenere i dati veri e propri Private m_PrivateCollection As Collection Private Sub Class_Initialize() ' l'assegnazione esplicita è leggermente più veloce dell'auto-istanziazione Set m_PrivateCollection = New Collection End Sub ' Aggiunge un nuovo elemento BaseClassName alla collezione Public Sub Add(newItem As BaseClassName, Optional Key As Variant) Attribute Add.VB_Description = "Adds a member to a Collection object" ' DA FARE: inizializzare in questo punto le proprietà del nuovo elemento ' ... ' aggiungere alla collezione privata m_PrivateCollection.Add newItem, Key End Sub

' Rimuove un elemento dalla collezione Public Sub Remove(index As Variant) Attribute Remove.VB_Description = "Removes a member from a Collection object" m_PrivateCollection.Remove index End Sub ' Restituisce un elemento BaseClassName della collezione Function Item(index As Variant) As BaseClassName Attribute Item.VB_Description = "Returns a specific member of a Collection " _ & "object either by position or key" Attribute Item.VB_UserMemId = 0 Set Item = m_PrivateCollection.Item(index) End Function ' Restituisce il numero di elementi della collezione Property Get Count() As Long Attribute Count.VB_Description = "Returns the number of members in a collection" Count = m_PrivateCollection.Count End Property ' Rimuove tutti gli elementi dalla collezione Public Sub Clear() Attribute Clear.VB_Description = "Removes all members from a Collection object" Set m_PrivateCollection = New Collection End Sub ' Implementa la gestione dell'enumerazione (For Each) Function NewEnum() As IUnknown Attribute NewEnum.VB_UserMemId = -4 Attribute NewEnum.VB_MemberFlags = "40" ' delega alla collezione privata Set NewEnum = m_PrivateCollection.[_NewEnum] End Function

Capitolo 11 - Oggetti COM Creare un GUID  Declare Function CoCreateGuid_Alt Lib "OLE32.DLL" Alias "CoCreateGuid" (pGuid _ As Any) As Long Declare Function StringFromGUID2_Alt Lib "OLE32.DLL" Alias "StringFromGUID2" _ (pGuid As Any, ByVal address As Long, ByVal Max As Long) As Long Function CreateGUID() As String Dim res As String, resLen As Long, guid(15) As Byte res = Space$(128) CoCreateGuid_Alt guid(0) resLen = StringFromGUID2_Alt(guid(0), ByVal StrPtr(res), 128) CreateGUID = Left$(res, resLen - 1) End Function

Registrare e deregistrare le componenti con i menu di  contesto  REGEDIT4 ; ActiveX DLLs [HKEY_CLASSES_ROOT\.dll] @="dllfile" [HKEY_CLASSES_ROOT\dllfile\shell\regdll] @="Register ActiveX DLL" [HKEY_CLASSES_ROOT\dllfile\shell\regdll\command] @="regsvr32.exe \"%L\"" [HKEY_CLASSES_ROOT\dllfile\shell\unregdll] @="Unregister ActiveX DLL" [HKEY_CLASSES_ROOT\dllfile\shell\unregdll\command] @="regsvr32.exe /u \"%L\"" ; ActiveX Controls [HKEY_CLASSES_ROOT\.ocx] @="ocxfile" [HKEY_CLASSES_ROOT\ocxfile\shell\regocx] @="Register OCX Control" [HKEY_CLASSES_ROOT\ocxfile\shell\regocx\command] @="regsvr32.exe \"%L\"" [HKEY_CLASSES_ROOT\ocxfile\shell\unregocx] @="Unregister OCX Control" [HKEY_CLASSES_ROOT\ocxfile\shell\unregocx\command] @="regsvr32.exe /u \"%L\"" ; ActiveX EXEs [HKEY_CLASSES_ROOT\.exe] @="exefile" [HKEY_CLASSES_ROOT\exefile\shell\regexe] @="Register ActiveX EXE" [HKEY_CLASSES_ROOT\exefile\shell\regexe\command] @="\"%L\" /regserver" [HKEY_CLASSES_ROOT\exefile\shell\unregexe] @="Unregister Active EXE" [HKEY_CLASSES_ROOT\exefile\shell\unregexe\command] @="\"%L\" /unregserver"

Individuare quando un nuovo controllo viene aggiunto ad un  contenitore ActiveX  Private Sub Timer1_Timer() Static ctrlCount As Integer

If ctrlCount <> ContainedControls.Count Then ctrlCount = ContainedControls.Count ' un nuovo controllo è stato aggiunto o rimosso ' dallo UserControl ' ' ...aggiungere del codice in questo punto........ ' End If End Sub ' ------ codice per vb6 Dim WithEvents tmrNotifier As Timer Private Sub UserControl_Initialize() ' crea dinamicamente un nuovo controllo Timer Set tmrNotifier = Controls.Add("VB.Timer", "tmrNotifier") tmrNotifier.Interval = 500 End Sub Private Sub tmrNotifier_Timer() Static ctrlCount As Integer If ctrlCount <> ContainedControls.Count Then ctrlCount = ContainedControls.Count ' un nuovo controllo è stato aggiunto o rimosso ' dallo UserControl ' ' ...aggiungere del codice in questo punto........ ' End If End Sub

Registrare e deregistrare le type library  ' Registra una type library Sub RegisterTypeLib(ByVal TypeLibFile As String) Dim TLI As New TLIApplication ' solleva un errore se non è in grado di registrare ' (ad esempio file not found or not a TLB) TLI.TypeLibInfoFromFile(TypeLibFile).Register End Sub ' Deregistra una type library Sub UnregisterTypeLib(ByVal TypeLibFile As String) Dim TLI As New TLIApplication ' solleva un errore se non è in grado di deregistrare TLI.TypeLibInfoFromFile(TypeLibFile).UnRegister End Sub

Determinare il CLSID di un oggetto COM  Function GetObjectGUID(Object As Object) As String Dim TLI As New TLIApplication GetObjectGUID = TLI.InterfaceInfoFromObject(Object).Guid End Function

Ottenere il valore Command$ da una DLL ActiveX  Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineA" _ () As Long Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal _ lpString1 As String, ByVal lpString2 As Long) As Long ' all'interno della DLL ActiveX Dim lpStr As Long, i As Long Dim buffer As String Dim exePath As String, cmdLine As String ' ottiene un puntatore alla riga di comando lpStr = GetCommandLine() ' copia in un buffer locale buffer = Space$(512) lstrcpy buffer, lpStr ' estrae la stringa che termina con un null buffer = Left$(buffer, InStr(buffer & vbNullChar, vbNullChar) - 1) If Left$(buffer, 1) = """" Then ' se la stringa comincia con le doppie virgolette, ' trova quelle di chiusura i = InStr(2, buffer, """") exePath = Mid$(buffer, 2, i - 2)

' ciò che rimane è la riga di comando cmdLine = LTrim$(Mid$(buffer, i + 1)) Else ' altrimenti trova lo spazio che separa ' il nome/percorso dell'EXE e la riga di comando i = InStr(buffer, " ") exePath = Left$(buffer, i - 1) cmdLine = LTrim$(Mid$(buffer, i)) End If

Determinare se una DLL ActiveX viene utilizzata da un  programma interpretato  Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As _ Long, ByVal lpfn As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal _ hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long ' questa variabile viene condivisa dalle due routine che seguono Dim m_ClientIsInterpreted As Boolean ' restituisce True se l'applicazione client di questa DLL ' è un programma Visual Basic interpretato in esecuzione all'interno dell'IDE ' ' NOTA: questo codice deve essere inserito in un modulo BAS ' all'interno di un progetto ActiveX DLL Function ClientIsInterpreted() As Boolean EnumThreadWindows App.ThreadID, AddressOf EnumThreadWindows_CBK, 0 ClientIsInterpreted = m_ClientIsInterpreted End Function ' questa è una funzione di callback che viene eseguita per ogni ' finestra appartenente allo stesso thread della DLL Public Function EnumThreadWindows_CBK(ByVal hWnd As Long, _ ByVal lParam As Long) As Boolean Dim buffer As String * 512 Dim length As Long Dim windowClass As String ' ottiene il nome della classe per questa finestra length = GetClassName(hWnd, buffer, Len(buffer)) windowClass = Left$(buffer, length) If windowClass = "IDEOwner" Then ' questa è la finestra principale dell'IDE di VB, pertanto ' l'applicazione client è interpretata m_ClientIsInterpreted = True ' restituisce False per interrompere l'enumerazione EnumThreadWindows_CBK = False Else ' restituisce True per continuare l'enumerazione EnumThreadWindows_CBK = True End If End Function

Determinare il CLSID associato a un ProgId  Private Declare Function CLSIDFromProgID Lib "ole32.dll" (ByVal lpszProgID As _ Long, pCLSID As Any) As Long Private Declare Function StringFromCLSID Lib "ole32.dll" (pCLSID As Any, _ lpszProgID As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _ Any, source As Any, ByVal bytes As Long) Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Function ProgIdToCLSID(ByVal ProgID As String) As String Dim pResult As Long, pChar As Long Dim char As Integer, length As Long Dim guid(15) As Byte ' ottieni il CLSID in forma binaria CLSIDFromProgID StrPtr(ProgID), guid(0) ' converti ad una stringa, ottieni un puntatore al risultato StringFromCLSID guid(0), pResult ' trova il carattere NULL finale pChar = pResult - 2 Do pChar = pChar + 2 CopyMemory char, ByVal pChar, 2 Loop While char ' leggi l'intera stringa in un'unica operazione length = pChar - pResult ' no need for a temporary string ProgIdToCLSID = Space$(length \ 2)

CopyMemory ByVal StrPtr(ProgIdToCLSID), ByVal pResult, length ' rilascia la memoria associata alla stringa CoTaskMemFree pResult End Function

Capitolo 12 - Database e oggetti ADO Consentire all'utente di creare una stringa di connessione  Dim dataLink As New MSDASC.DataLinks Dim connString As String Dim cn As New ADODB.Connection ' l'istruzione seguente rende la proprietà modale rispetto alla form corrente dataLink.hWnd = Me.hWnd ' visualizza la finestra di dialogo On Error Resume Next connString = dataLink.PromptNew If Err = 0 Then ' Crea un oggetto Connection su questa stringa di connessione cn.ConnectionString = connString Else ' L'utente ha cancellato l'operazione End If

Esportare in un file di testo con campi delimitati da virgolette  Dim rs As New ADODB.Recordset, tmp As String rs.Open "authors", "DSN=pubs", adOpenForwardOnly, , adCmdTable Open "c:\authors.dat" For Output As #1 ' genera le virgolette di apertura per il primo ' campo del primo record Print #1, """" ' genera il resto del recordset Do Until rs.EOF ' blocchi da 100 record ciascuno tmp = rs.GetString(, 100, """,""", """" & vbCrLf & """", "") If rs.EOF Then ' elimina le doppie virgolette in eccesso tmp = Left$(tmp, Len(tmp) - 1) End If Print #1, tmp; Loop Close #1

Creare velocemente una copia di un Recordset di ADO  Dim Dim Dim Dim

rsSource As New ADODB.Recordset rsFiltered As ADODB.Recordset rsSorted As ADODB.Recordset pb As New PropertyBag

' apre un Recordset lato client rsSource.CursorLocation = adUseClient rsSource.Open "Authors", "DSN=Pubs", adOpenStatic ' applica un filtro rsSource.Filter = "author like 'J*'" ' crea una copia del Recordset filtrato pb.WriteProperty "filtered", rsSource Set rsFiltered = pb.ReadProperty("filtered") ' ordina il Recordset rsSource.Filter = "" rsSource.Sort = "Author" ' crea una copia del Recordset ordinato pb.WriteProperty "sorted", rsSource Set rsSorted = pb.ReadProperty("sorted") ' libera la memoria Set pb = Nothing

Minor overhead con i Recordset disconnessi  ' ' ' ' ' '

Apre un recordset vuoto da un file serializzato. Se il file non esiste, utilizza gli ultimi due argomenti per crearlo. ConnString dovrebbe essere una stringa di connessione valida. Source dovrebbe essere una clausola di SELECT che restituisce zero record Esempio:

Dim rs As ADODB.Recordset

' '

'

Set rs = GetEmptyRecordset("c:\empty.rs", "DSN=Pubs", "SELECT * FROM Authors WHERE 0=1"

Function GetEmptyRecordset(ByVal Filename As String, ByVal ConnString As String, _ ByVal Source As String) As ADODB.Recordset Dim rs As New ADODB.Recordset ' controlla se il file esiste già If Len(Dir$(Filename)) = 0 Then ' il file non è stato trovato, si connette al database rs.Open Source, ConnString, adOpenStatic, adLockBatchOptimistic ' quindi lo salva per le sessioni future rs.Save Filename rs.Close End If ' apre il file rs.Open Filename, , , , adCmdFile Set GetEmptyRecordset = rs End Function ' Riconnette un recordset al database ed esegue ' un aggiornamento batch Sub ReconnectRecordset(rs As ADODB.Recordset, ByVal ConnString As String) Dim cn As New ADODB.Connection ' apre la connessione cn.Open ConnString ' esegue l'aggiornamento batch Set rs.ActiveConnection = cn rs.UpdateBatch ' disconnette il recordset e chiude la connessione Set rs.ActiveConnection = Nothing cn.Close End Sub ' --------- esempio di utilizzo ------' ' ' '

Aggiunge nuovi record alla tabella Authors del database Pubs utilizzando un Recordset disconnesso e senza una connessione iniziale (più precisamente, questo codice eseguirà una connessione iniziale extra solo quando viene eseguito per la prima volta).

Const CONN_STRING = "Provider=SQLOLEDB.1;User ID=sa;" & _ "Initial Catalog=pubs;Data Source=P2" Const SOURCE_STRING = "SELECT * FROM Authors WHERE 1=0" Dim rs As New ADODB.Recordset ' Ottiene la struttura del Recordset Set rs = GetEmptyRecordset("c:\empty.rs", CONN_STRING, SOURCE_STRING) ' Aggiunge un record rs.AddNew rs("au_id") = "978-43-6543" rs("au_fname") = "Francesco" rs("au_lname") = "Balena" rs("city") = "Menlo Park" rs("State") = "CA" rs("Zip") = "94025" rs("Contract") = 1 rs.Update ' Aggiungere qui altri record, se lo si desidera ' ..... ' Aggiorna il database ReconnectRecordset rs, CONN_STRING rs.Close

Leggere e scrivere un campo binario (BLOB)  Sub FileToBlob(fld As ADODB.Field, filename As String) Const ChunkSize As Long = 8192 Dim fnum As Integer, bytesLeft As Long, bytes As Long Dim tmp() As Byte ' errore se il field non supporta il metodo GetChunk. If (fld.Attributes And adFldLong) = 0 Then Err.Raise 1001, , "Field doesn't support the GetChunk method." End If ' Errore se non esiste il file If Dir$(filename) = "" Then Err.Raise 53, , "File not found" fnum = FreeFile Open filename For Binary As fnum

' Leggi il file in blocchi di 8K e appendi il contenuto al Field bytesLeft = LOF(fnum) Do While bytesLeft bytes = bytesLeft If bytes > ChunkSize Then bytes = ChunkSize ReDim tmp(1 To bytes) As Byte Get #1, , tmp fld.AppendChunk tmp bytesLeft = bytesLeft - bytes Loop Close #fnum End Sub Sub BlobToFile(fld As ADODB.Field, filename As String) Const ChunkSize As Long = 8192 Dim fnum As Integer, bytesLeft As Long, bytes As Long Dim tmp() As Byte ' errore se il field non supporta il metodo GetChunk. If (fld.Attributes And adFldLong) = 0 Then Err.Raise 1001, , "Field doesn't support the GetChunk method." End If ' Cancella il file se esiste, e creane uno nuovo If Dir$(filename) <> "" Then Kill filename fnum = FreeFile Open filename For Binary As fnum ' Leggi il contenuto del Field e scrivi i dati ad un file ' per evitare problemi di memoria il file viene letto a blocchi di 8K bytesLeft = fld.ActualSize Do While bytesLeft bytes = bytesLeft If bytes > ChunkSize Then bytes = ChunkSize tmp = fld.GetChunk(bytes) Put #fnum, , tmp bytesLeft = bytesLeft - bytes Loop Close #fnum End Sub

Ottenere l'elenco dei driver ODBC  ' popola una casella di riepilogo con l'elenco di tutti i DSN disponibili Dim odbcTool As New ODBCTool.Dsn Dim Dsn() As String, i As Long If odbcTool.GetOdbcDriverList(Dsn()) Then ' un valore di ritorno True significa successo lstOdbcDrivers.Clear For i = 0 To UBound(dsn) lstOdbcDrivers.AddItem dsn(i) Next Else ' un valore di ritorno False significa errore MsgBox "Unable to read ODBC driver list", vbExclamation End If

Ottenere l'elenco dei DSN ODBC  ' popola una casella di riepilogo con l'elenco di tutti i DSN disponibili Dim odbcTool As New ODBCTool.Dsn Dim Dsn() As String, i As Long If odbcTool.GetDataSourceList(Dsn()) Then ' un valore di ritorno True significa successo lstDataSources.Clear For i = 0 To UBound(dsn) lstDataSources.AddItem dsn(i) Next Else ' un valore di ritorno False significa errore MsgBox "Unable to read DSN list", vbExclamation End If

Creare ed eliminare i DSN a runtime  ' Le funzioni API per il Registry Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal _ hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, _ ByVal lpszAttributes As String) As Long Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _ (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _ ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" Alias _ "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _ ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, _ ByRef lpcbData As Long) As Long

Const REG_SZ = 1 Const KEY_ALL_ACCESS = &H2003F Const HKEY_CURRENT_USER = &H80000001 Public Const ODBC_ADD_DSN = 1 Public Const ODBC_REMOVE_DSN = 3

' Aggiunge una sorgente dati ' Elimina la sorgente dati

Sub MakeDSN(ByVal sDSN As String, ByVal sDriver As String, _ ByVal sDBFile As String, ByVal lAction As Long) Dim sAttributes As String Dim sDBQ As String Dim lngRet As Long Dim hKey As Long Dim regValue As String Dim valueType As Long ' interroga il Registry per controllare se il DSN è già stato installato ' apre la chiave If RegOpenKeyEx(HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI\" & sDSN, 0, _ KEY_ALL_ACCESS, hKey) = 0 Then ' zero significa nessun errore => estrae il valore della chiave "DBQ" regValue = String$(1024, 0) ' alloca lo spazio per la variabile If RegQueryValueEx(hKey, "DBQ", 0, valueType, regValue, _ Len(regValue)) = 0 Then ' zero significa OK, pertanto è possibile estrarre il valore If valueType = REG_SZ Then sDBQ = Left$(regValue, InStr(regValue, vbNullChar) - 1) End If End If ' chiude la chiave RegCloseKey hKey End If ' Esegue l'azione solo se viene aggiunto un DSN che non esiste ' oppure rimuove un DSN esistente If (sDBQ = "" And lAction = ODBC_ADD_DSN) Or (sDBQ <> "" And lAction = _ ODBC_REMOVE_DSN) Then ' controlla che il file esista effettivamente If Len(Dir$(sDBFile)) = 0 Then MsgBox "Database file doesn't exist!", vbOKOnly + vbCritical Exit Sub End If sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes) End If End Sub ' --- esempio ----sDriver sName = sFile = MakeDSN

= "Microsoft Access Driver (*.mdb)" "DSN Creation Test" App.Path & "\MyDatabase.mdb" sName, sDriver, sFile, ODBC_ADD_DSN

Leggere e scrivere i file ODBC di definizione delle sorgenti  dati  ' crea un File DSN che punta ad un database di SQL Server ' ' se ServerName viene omesso, si connette all'istanza locale di SQL Server Sub CreateSQLServerDSN(ByVal DSNFile As String, ByVal DatabaseName As String, _ ByVal UserName As String, ByVal Password As String, _ Optional ByVal ServerName As String, Optional ByVal Description As String) Dim fnum As Integer Dim isOpen As Boolean On Error GoTo ErrorHandler fnum = FreeFile Open DSNFile For Output As #fnum isOpen = True Print #fnum, "[ODBC]" Print #fnum, "DRIVER=SQL Server" Print #fnum, "UID=" & UserName Print #fnum, "DATABASE=" & DatabaseName Print #fnum, "SERVER=" & IIf(ServerName = "", "(local)", ServerName) If Not IsMissing(Description) Then Print #fnum, "DESCRIPTION=" & Description End If

Close #fnum Exit Sub ErrorHandler: If isOpen Then Close #fnum Err.Raise Err.Number, , Err.Description End Sub

Estrarre l'elenco delle stored procedure di SQL Server  Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim connString As String, sql As String ' Apre una connessione – sostituire "myserver" con il nome del SQL Server da usare connString = "Provider=SQLOLEDB;Data Source=myserver;Initial Catalog=Pubs" cn.Open connString, "sa", "" ' Apre il recordset sql = "Select * from sysobjects where type = 'P' and category = 0" rs.Open sql, cn, adOpenStatic, adLockReadOnly, adCmdText ' Carica i risultati in un controllo DataGrid Set DataGrid1.DataSource = rs DataGrid1.Refresh ' ------ secondo listato -------' Questo codice assume che il recordset RS punti effettivamente ' alla stored procedure della quale si desiderano ' estrarre i parametri Dim rs2 As New ADODB.Recordset, sql2 As String sql2 = "SELECT syscolumns.Name, systypes.Name, syscolumns.length " & _ "FROM syscolumns, systypes " & "WHERE syscolumns.xtype = systypes.type AND " _ & "syscolumns.id = " & rs("ID") ' apre un secondo recordset rs2.Open sql2, cn, adOpenStatic, adLockReadOnly, adCmdText ' Lo assegna ad una seconda griglia Set DataGrid2.DataSource = rs2 DataGrid2.Refresh

Salvare una matrice in una tabella di SQL Server con VB ed  ADO  ' Nome della classe: CDBVariant Dim mCn As ADODB.Connection ' imposta la connessione che deve essere utilizzata dalla classe Public Property Set DataSource(newVal As ADODB.Connection) Set mCn = newVal End Property ' legge il Variant dal DB ' tblName = nome della tabella sorgente ' Name = nome della variabile da leggere Public Property Get DBVariant(tblName As String, Name As String) As Variant Dim strFilter As String, pb As New PropertyBag, vtTemp As Variant Dim rs As New ADODB.Recordset strFilter = "Name = '" & Name & "'" rs.Open "SELECT * FROM " & tblName & " WHERE " & strFilter, mCn, _ adOpenStatic, adLockPessimistic If Not rs.EOF And Not rs.BOF Then vtTemp = rs!Data pb.Contents = vtTemp If pb.ReadProperty("Size", 0) = 0 Then DBVariant = pb.ReadProperty("Value", vbNull) Else Dim vtTemp2() As Variant ReDim vtTemp2(pb.ReadProperty("Size", 0)) As Variant For i = 0 To UBound(vtTemp2) vtTemp2(i) = pb.ReadProperty(CStr(i)) Next DBVariant = vtTemp2 End If End If Set rs = Nothing End Property ' scrive il Variant nel DB

' tblName = nome della tabella di destinazione ' Name = nome della variabile Public Property Let DBVariant(tblName As String, Name As String, _ newValue As Variant) Dim strFilter As String, pb As New PropertyBag Dim rs As New ADODB.Recordset Dim bRemove As Boolean strFilter = "Name = '" & Name & "'" rs.Open "SELECT * FROM " & tblName & " WHERE " & strFilter, mCn, _ adOpenStatic, adLockPessimistic If VarType(newValue) = vbObject Then bRemove = newValue Is Nothing Else bRemove = False End If If Not bRemove Then If rs.EOF And rs.BOF Then rs.AddNew rs!Name = Name End If If (VarType(newValue) And vbArray) = 0 Then ' valore scalare pb.WriteProperty "Size", 0 pb.WriteProperty "Value", newValue Else ' preparazione di uno stream per array pb.WriteProperty "Size", UBound(newValue) For i = 0 To UBound(newValue) pb.WriteProperty CStr(i), newValue(i) Next End If rs!Data = CVar(pb.Contents) rs.Update Else If Not rs.EOF And Not rs.BOF Then rs.Delete End If End If Set rs = Nothing End Property ' ---------- esempio d'utilizzo -----------Dim t As New cDBVariant Dim cn As New ADODB.Connection Dim vArray(100) As Integer Dim vArray2 As Variant ' apre una connessione cn.Open "file name=c:\udl\master.udl" For i = 1 To UBound(vArray) vArray(i) = i Next ' assegna la connessione alla classe Set t.DataSource = cn ' scrive la matrice t.DBVariant("tblArrays", "vArray") = vArray ' legge la matrice vArray2 = t.DBVariant("tblArrays", "vArray") ' scarica i risultati Debug.Print UBound(vArray2) For i = 1 To UBound(vArray2) Debug.Print vArray2(i) Next

Connettere un Recordset stand-alone ad un database  utilizzando l'XML ' Richiede IE 5 ed un riferimento a ' ADO 2.5 e alla type library MSXML2

Sub LinkRsToDB(ByVal rs As ADODB.Recordset, ByVal BaseCatalog As String, _ ByVal BaseTable As String) Dim DOMDoc As New DOMDocument Dim Root As IXMLDOMNode Dim Schema As IXMLDOMNode Dim Node As IXMLDOMNode Dim Item As IXMLDOMNode Dim NewItem As IXMLDOMAttribute ' apre il recordset se necessario If (rs.State And adStateOpen) = 0 Then rs.Open ' salva il recordset direttamente nel parser XML rs.Save DOMDoc, adPersistXML ' Schema è il primo nodo sotto la radice Set Root = DOMDoc.childNodes.Item(0) Set Schema = Root.childNodes(0) For Each Node In Schema.childNodes(0).childNodes If UCase(Node.baseName) = "ATTRIBUTETYPE" Then For Each Item In Node.Attributes If Item.baseName = "write" Then ' Rimuove questo attributo, che non verrà gestito ' all'atto del caricamento del Recordset Node.Attributes.removeQualifiedItem Item.baseName, _ Item.namespaceURI Exit For End If Next ' Crea gli attributi mancanti per il Recordset Set NewItem = DOMDoc.createAttribute("rs:basecatalog") NewItem.Value = BaseCatalog Node.Attributes.setNamedItem NewItem Set NewItem = DOMDoc.createAttribute("rs:basetable") NewItem.Text = BaseTable Node.Attributes.setNamedItem NewItem Set NewItem = DOMDoc.createAttribute("rs:basecolumn") ' Assume che il nome logico sia uguale al nome fisico NewItem.Text = Node.Attributes(0).Text Node.Attributes.setNamedItem NewItem ' questo attributo è necessario in ADO 2.5 Set NewItem = DOMDoc.createAttribute("rs:writeunknown") NewItem.Text = "true" Node.Attributes.setNamedItem NewItem End If Next ' ricarica il recordset dal parser rs.Close rs.Open DOMDoc End Sub ' ------- usempio di utilizzo Dim rs As New ADODB.Recordset Dim cn As New ADODB.Connection rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append rs.Fields.Append

"au_id", adVarChar, 11 "au_lname", adVarChar, 40 "au_fname", adVarChar, 20 "phone", adChar, 12 "address", adVarChar, 40 "city", adVarChar, 20 "state", adChar, 2 "zip", adChar, 5 "contract", adBoolean

' Aggiunge un nuovo record al recordset rs.Open rs.AddNew rs("au_id") = "978-43-6543" rs("au_fname") = "Francesco" rs("au_lname") = "Balena" rs("city") = "Menlo Park" rs("State") = "CA" rs("Zip") = "94025" rs("Contract") = 1 rs.Update ' utilizza la routine LinkRsToDB per modificare il Recordset ' e fa in modo che possa connettersi ad un database: LinkRsToDB rs, BaseCatalog:="Pubs", BaseTable:="Authors"

' apre la connessione vera e propria e la associa al recordset cn.Open "DSN=Pubs" Set rs.ActiveConnection = cn ' Aggiorna il database ' non eseguendo la procedura LinkRsToDB, si otterrebbe un errore ' "Insufficient base table information for updating or refreshing.") rs.UpdateBatch ' ------- versione per ADO 2.1 ' Richiede ADO 2.1 e la type library MSXML 2.0 Sub LinkRsToDB(ByVal rs As ADODB.Recordset, ByVal BaseCatalog As String, _ ByVal BaseTable As String) Dim DOMDoc As New DOMDocument Dim Root As IXMLDOMNode Dim Schema As IXMLDOMNode Dim Node As IXMLDOMNode Dim Item As IXMLDOMNode Dim NewItem As IDOMAttribute Dim XMLSource As String Dim tempFileName As String Dim fileNum As Integer ' modificare questo nome di file o utilizzare la routine GetTempFile, che ' può essere scaricata da questo URL: ' http://www.vb2themax.com/Item.asp?PageID=CodeBank&ID=48 tempFileName = "C:\Empty.xml" ' verifica che il file non ci sia già On Error Resume Next Kill tempFileName On Error GoTo 0 ' apre il recorset se necessario If (rs.State And adStateOpen) = 0 Then rs.Open ' salva il recordset nel file temporaneo in formato XML rs.Save tempFileName, adPersistXML ' ricarica il testo XML nel parser DOMDoc.Load tempFileName Set Root = DOMDoc.childNodes.Item(0) Set Schema = Root.childNodes(0) For Each Node In Schema.childNodes If UCase(Node.baseName) = "ATTRIBUTETYPE" Then For Each Item In Node.Attributes If Item.baseName = "write" Then ' Rimuove questo attributo, che non verrà gestito ' all'atto del caricamento del Recordset Node.Attributes.removeNamedItem Item.nodeName Exit For End If Next ' Crea gli attributi mancanti per il Recordset Set NewItem = DOMDoc.createAttribute("rs:basecatalog") NewItem.Value = BaseCatalog Node.Attributes.setNamedItem NewItem Set NewItem = DOMDoc.createAttribute("rs:basetable") NewItem.Value = BaseTable Node.Attributes.setNamedItem NewItem Set NewItem = DOMDoc.createAttribute("rs:basecolumn") ' Assume che il nome logico sia uguale al nome fisico NewItem.Value = Node.Attributes(0).nodeValue Node.Attributes.setNamedItem NewItem End If Next ' i Recordset di ADO conoscono solo il carattere apostrofo XMLSource = Replace(DOMDoc.xml, Chr(34), "'") ' salva l'XML modificato nel file temporaneo Kill tempFileName fileNum = FreeFile Open tempFileName For Output As #fileNum Print #fileNum, XMLSource Close #fileNum ' ricarica il recordset da qui rs.Close rs.Open tempFileName, , , , adCmdFile ' elimina il file temporaneo

Kill tempFileName End Sub ' --------- ultimo listato ---------Dim rs As New ADODB.Recordset Dim cn As New ADODB.Connection ' solo un campo in questo esempio rs.Fields.Append "Author", adVarChar, 50 rs.Open ' Aggiunge un nuovo record al recordset rs.AddNew rs("author") = "Francesco Balena" rs.Update ' fa in modo che il recordset sia in grado di connettersi LinkRsToDB rs, BaseCatalog:="", BaseTable:="Authors" ' questo data link punta a Biblio.mdb cn.Open "File Name=C:\DataLinks\Biblio.udl" Set rs.ActiveConnection = cn ' invia gli aggiornamenti al database rs.UpdateBatch

Capitolo 13 - Linguaggio SQL e programmazione con Microsoft SQL Server Elencare tutti gli indici di un database di SQL Server  /* SP sp_help_db_indexes: elenca tutti gli indici di tutte le tabelle del database */ CREATE procedure sp_help_db_indexes AS declare @empty varchar(1) select @empty = '' -- 35 è la lunghezza del nome del campo della tabella master.dbo.spt_values declare @IgnoreDuplicateKeys varchar(35), @Unique varchar(35), @IgnoreDuplicateRows varchar(35), @Clustered varchar(35), @Hypotethical varchar(35), @Statistics varchar(35), @PrimaryKey varchar(35), @UniqueKey varchar(35), @AutoCreate varchar(35), @StatsNoRecompute varchar(35) select @IgnoreDuplicateKeys = name from master.dbo.spt_values where type = 'I' and number = 1 --ignore duplicate keys select @Unique = name from master.dbo.spt_values where type = 'I' and number = 2 --unique select @IgnoreDuplicateRows = name from master.dbo.spt_values where type = 'I' and number = 4 --ignore duplicate rows select @Clustered = name from master.dbo.spt_values where type = 'I' and number = 16 --clustered select @Hypotethical = name from master.dbo.spt_values where type = 'I' and number = 32 --hypotethical select @Statistics = name from master.dbo.spt_values where type = 'I' and number = 64 --statistics select @PrimaryKey = name from master.dbo.spt_values where type = 'I' and number = 2048 --primary key select @UniqueKey = name from master.dbo.spt_values where type = 'I' and number = 4096 --unique key select @AutoCreate = name from master.dbo.spt_values where type = 'I' and number = 8388608 --auto create select @StatsNoRecompute = name from master.dbo.spt_values where type = 'I' and number = 16777216 --stats no recompute select o.name, i.name, 'index description' = convert(varchar(210), --bits 16 off, 1, 2, 16777216 on case when (i.status & 16)<>0 then @Clustered else 'non'+@Clustered end + case when (i.status & 1)<>0 then ', '+@IgnoreDuplicateKeys else @empty end + case when (i.status & 2)<>0 then ', '+@Unique else @empty end + case when (i.status & 4)<>0 then ', '+@IgnoreDuplicateRows else @empty end + case when (i.status & 64)<>0 then ', '+@Statistics else case when (i.status & 32)<>0 then ', '+@Hypotethical else @empty end end + case when (i.status & 2048)<>0 then ', '+@PrimaryKey else @empty end + case when (i.status & 4096)<>0 then ', '+@UniqueKey else @empty end + case when (i.status & 8388608)<>0 then ', '+@AutoCreate else @empty end + case when (i.status & 16777216)<>0 then ', '+@StatsNoRecompute else @empty end), 'index column 1' = index_col(o.name,indid, 1), 'index column 2' = index_col(o.name,indid, 2), 'index column 3' = index_col(o.name,indid, 3) from sysindexes i, sysobjects o where i.id = o.id and indid > 0 and indid < 255 -all the clustered (=1), non clusterd (>1 and <251), and text or image (=255) and o.type = 'U' -user table --ignore the indexes for the autostat and (i.status & 64) = 0 -index with duplicates and (i.status & 8388608) = 0 -auto created index and (i.status & 16777216)= 0 --stats no recompute order by o.name

Elencare i permessi degli utenti sugli oggetti di un database  /* SP sp_get_object_permissions: elenca i permessi di ogni utenti sulle tabelle, le viste e le stored procedure del database attivo */ CREATE PROCEDURE sp_get_object_permissions AS

DECLARE @obj_name VARCHAR(30) DECLARE @obj_type CHAR(2) DECLARE @message VARCHAR(75) DECLARE tblnames CURSOR FOR SELECT name, type FROM sysobjects WHERE type IN ('U','P','V') ORDER BY 2 DESC OPEN tblnames FETCH NEXT FROM tblnames INTO @obj_name, @obj_type WHILE (@@fetch_status <> -1) BEGIN IF (@@fetch_status <> -2) BEGIN IF @obj_type = 'U' SELECT @message = 'Checking the rights for the Table ' IF @obj_type = 'V' SELECT @message = ' Checking the rights for the Vable ' IF @obj_type = 'P' SELECT @message = ' Checking the rights for the Stored Procedure ' SELECT @message = @message + RTRIM(UPPER(@obj_name)) PRINT @message EXEC ('sp_helprotect ' + @obj_name ) END FETCH NEXT FROM tblnames INTO @obj_name, @obj_type END CLOSE tblnames DEALLOCATE tblnames

Condivisione di connessioni  /* Begin of script InstallCS.Sql */ -- seleziona del database master USE master go IF EXISTS (SELECT name FROM sysobjects WHERE name = 'sp_CSUnpublish' AND type = 'P') DROP PROCEDURE sp_CSUnpublish go IF EXISTS (SELECT name FROM sysobjects WHERE name = 'sp_CSPublish' AND type = 'P') DROP PROCEDURE sp_CSPublish go IF EXISTS (SELECT name FROM sysobjects WHERE name = 'sp_CSInitialize' AND type = 'P') DROP PROCEDURE sp_CSInitialize go IF EXISTS (SELECT name FROM sysobjects WHERE name = 'sp_CSSubscribe' AND type = 'P') DROP PROCEDURE sp_CSSubscribe go IF EXISTS (SELECT name FROM sysobjects WHERE name = 'sp_CSUnsubscribe' AND type = 'P') DROP PROCEDURE sp_CSUnsubscribe go -- Stored procedure di inizializzazione CREATE PROCEDURE sp_CSInitialize AS BEGIN -- Elimina la tabella precedente the previous table drop table IsolationTemp -- Crea una nuova copia della tabella di supporto create table IsolationTemp(SysUser varchar(64) primary key, BindToken varchar(4096), SysSPID integer) -- Consente agli utenti del gruppo public di utilizzare completamente la tabella GRANT ALL ON IsolationTemp TO public END go -- Imposta la stored procedura sp_CSInitialize in modo che parta automaticamente sp_procoption 'sp_CSInitialize', 'startup', true go -- Termina la pubblicazione del proprio livello di isolamento CREATE PROCEDURE sp_CSUnpublish AS BEGIN -- Elimina i record dell'utente corrente dalla tabella di supporto DELETE FROM master.dbo.IsolationTemp where sysUser = system_user END go

-- Pubblica il proprio livello di isolamento CREATE PROCEDURE sp_CSPublish AS BEGIN DECLARE @bind_token varchar(255) -- Ottiene il token del proprio livello di isolamento EXECUTE sp_getbindtoken @bind_token OUTPUT -- Elimina le voci precedenti exec sp_CSUnpublish -- Crea le nuove voci dal livello di isolamento corrente INSERT INTO master.dbo.IsolationTemp (SysUser, BindToken, SysSPID) VALUES (system_user, @bind_token, @@SPID) END go -- Sottoscrive un livello di isolamento pubblicato CREATE PROCEDURE sp_CSSubscribe AS BEGIN declare @BindToken varchar(4096) -- Ottiene il token select @BindToken = (SELECT TOP 1 BindToken From master.dbo.IsolationTemp (NOLOCK) Where SysUser = SYSTEM_USER) -- Aggancia il livello di isolamento exec sp_BindSession @BindToken END go -- Rifiuta il livello di isolamento sottoscritto CREATE PROCEDURE sp_CSUnsubscribe AS BEGIN exec sp_BindSession NULL END go grant grant grant grant grant

all all all all all

on on on on on

sp_CSUnpublish to public sp_CSPublish to public sp_CSInitialize to public sp_CSSubscribe to public sp_CSUnsubscribe to public

-- Prima esecuzione della stored procedure di inizializzazione exec sp_CSInitialize go /* End of script InstallCS.Sql */

Effettuare il backup di un database MSDE utilizzando T-SQL -- Creazione del job di backup USE msdb EXEC sp_add_job @job_name = 'BackupJob', @enabled = 1, @description = 'BackupJob', @owner_login_name = 'sa', @notify_level_eventlog = 2, @notify_level_email = 2, @notify_level_netsend =2, @notify_level_page = 2 @notify_email_operator_name = 'myMailAddress' go -- Backup dei dati USE msdb EXEC sp_add_jobstep @job_name = 'BackupJob', @step_name = 'msdb database backup', @subsystem = 'TSQL', @command = 'BACKUP DATABASE msdb TO DISK = ''c:\msdb.dat_bak''', @on_success_action = 3, @retry_attempts = 5, @retry_interval = 5 go -- Backup del file di log USE msdb EXEC sp_add_jobstep @job_name = 'myTestBackupJob', @step_name = 'msdb Log backup', @subsystem = 'TSQL', @command = 'BACKUP LOG msdb TO DISK = ''c:\msdb.log_bak''', @on_success_action = 1, @retry_attempts = 5, @retry_interval = 5 go -- Specifica del server USE msdb EXEC sp_add_jobserver @job_name = 'BackupJob', @server_name = N'(local)' -- Esecuzione immediate del job USE msdb EXEC sp_start_job @job_name = 'myTestBackupJob'

Eseguire query distrubuite utilizzando un linked server  Dim cn As ADODB.Connection Set cn = New ADODB.Connection cn.Open "Provider=SQLOLEDB;Data Source=(local);Initial Catalog=master;User " _ & "Id=sa;Password=;" cn.Execute "EXEC sp_addlinkedserver 'MyLinkedServerName', 'Jet 4.0', " _ & "'Microsoft.Jet.OLEDB.4.0', 'c:\program files\microsoft " _ & "office\office\samples\northwind.mdb'" cn.Execute "EXEC sp_addlinkedsrvlogin ' MyLinkedServerName ', FALSE, NULL, " _ & "'admin', ''" cn.Close Set cn = Nothing ' -------- secondo listato Dim rs As ADODB.Recordset Dim cn As ADODB.Connection Dim SQL As String Set cn = New ADODB.Connection Set rs = New ADODB.Recordset ' la funzione OPENQUERY SQL = " Select a.* from OPENQUERY(MyLinkedServerName, 'Select * from " _ & "Customers') a" ' la funzione OPENROWSET SQL = "SELECT * From OPENROWSET('Microsoft.Jet.OLEDB.4.0','c:\program " _ & "files\microsoft office\office\samples\northwind.mdb'; 'Admin';'', " _ & "Customers)" ' la sintassi a quattro parti SQL = "Select * from MyLinkedServerName...Customers" cn.CursorLocation = adUseClient cn.Open "Provider=SQLOLEDB;Data Source=(local);Initial Catalog=master;User " _ & "Id=sa;Password=;" rs.Open SQL, cn, adOpenStatic, adLockReadOnly ' ... rs.Close set rs = Nothing cn.Close Set cn = Nothing

Inviare Fax da Microsoft SQL Server utilizzando Microsoft  Word  DECLARE DECLARE DECLARE DECLARE DECLARE DECLARE

@WordDocument int @WordApplication int @Content int @visible int @hr int @text varchar(4096)

-- Set WordDocument = CreateObject("Word.Document") EXEC @hr = sp_OACreate 'word.Document', @WordDocument OUT -- Set Application = WordDocument.Application IF @hr = 0 EXEC @hr = sp_OAGetProperty @WordDocument, 'Application', @WordApplication OUT -- Set Content = WordDocument.Content IF @hr = 0 EXEC @hr = sp_OAGetProperty @WordDocument, 'Content', @Content OUT -- Content.Text = "Word Document " + vbNewLine + "generated by SQL Server" IF @hr = 0 BEGIN set @text = 'Word Document' + char(10) + 'generated by SQL Server' EXEC @hr = sp_OASetProperty @Content, 'Text', @text END -- WordApplication.Visible = True IF @hr = 0 BEGIN EXEC @hr = sp_OASetProperty @WordApplication, 'Visible', 1 waitfor delay '00:00:10' END -- WordDocument.SendFax "", "Send a fax from SQL Server" IF @hr = 0 EXEC @hr = sp_OAMethod @WordDocument, 'SendFax', NULL, '', 'Invio fax da SQL Server'

IF @hr <> 0 BEGIN print "ERROR OCCURRED: " + cast(@hr as varchar(128)) RETURN END

Elencare tutte le installazioni di SQL Server esistenti  ' NOTA: questo codice assume che sia stato aggiunto un riferimento alla type library ' SQL-DMO nella finestra di dialogo References Dim sqlApp As New SQLDMO.Application Dim NameList As SQLDMO.NameList Dim index As Long Set NameList = sqlApp.ListAvailableSQLServers cboServers.Clear ' l'installazione locale di SQL Server deve essere aggiunta manualmente cboServers.AddItem "." For index = 1 To NameList.Count cboServer.AddItem NameList.Item(index) Next

Lanciare ed interrompere programmaticamente il servizio  principale di SQL Server  ' NOTA: questo codice assume che sia stato aggiunto un riferimento ' alla type library SQL-DMO nella finestra di dialogo References ' lancia, sospende, riavvia ed interrompe il servizio principale di SQL Server Dim SQLServer As New SQLDMO.SQLServer ' per lanciare il servizio è necessario specificare ' il nome del server e le credenziali dell'utente SQLServer.Start False, "MyServer", "sa", "mypwd" ' per sospendere, riavviare ed interrompere il servizio ' non occorre alcun argomento aggiuntivo SQLServer.Pause SQLServer.Continue SQLServer.Stop ' mostra lo stato corrente del servizio Select Case SQLServer.Status Case SQLDMOSvc_Paused: lblStatus = "Paused" Case SQLDMOSvc_Running: lblStatus = "Running" Case SQLDMOSvc_Starting: lblStatus = "Starting" Case SQLDMOSvc_Stopped: lblStatus = "Stopped" End Select

Monitoraggio avanzato dei lock  /* Start of sp_ExBlockingLocks.sql stored procedure*/ /* Original version: Ron Soukup, Kalen Delany */ use master go IF EXISTS( SELECT name FROM sysobjects WHERE name = 'sp_ExBlockingLocks' AND type = 'P') drop proc sp_ExBlockingLocks go create procedure sp_ExBlockingLocks as set nocount on select DISTINCT sp.hostname HostName, sp.program_name "Prg Name", sp.hostprocess "PID", sp.nt_domain "DOMAIN", sp.nt_username "Usr Name", sp.net_address "Net Addr", sp.loginame "Login", convert (smallint, l1.req_spid) As spid, l1.rsc_dbid As dbid, (SELECT name from master.dbo.sysdatabases (nolock) where dbid = l1.rsc_dbid) As Db, l1.rsc_objid As ObjId, (select name from sysobjects (nolock) where id = l1.rsc_objid) As Obj, l1.rsc_indid As IndId, substring (v.name, 1, 4) As Type, substring (l1.rsc_text, 1, 16) as Resource, substring (u.name, 1, 8) As Mode, substring (x.name, 1, 5) As Status from master.dbo.syslockinfo l1,

master.dbo.syslockinfo l2, master.dbo.spt_values v, master.dbo.spt_values x, master.dbo.spt_values u, master.dbo.sysprocesses sp where l1.rsc_type = v.number and v.type = 'LR' and l1.req_status = x.number and x.type = 'LS' and l1.req_mode + 1 = u.number and u.type = 'L' and l1.rsc_type <>2 /* not a DB lock */ and l1.rsc_dbid = l2.rsc_dbid and l1.rsc_bin = l2.rsc_bin and l1.rsc_objid = l2.rsc_objid and l1.rsc_indid = l2.rsc_indid and l1.req_spid <> l2.req_spid and l1.req_status <> l2.req_status and sp.spid = l1.req_spid order by substring (l1.rsc_text, 1, 16), substring (x.name, 1, 5) return (0) /* End of stored procedure */

Capitolo 14 – Multimedia Determinare la durata complessiva di un CD audio  Private Sub cmdDisplayTime_Click() Dim Value As Integer Dim TotalTime As String With MMControl1 ' Inizializza il controllo Multimedia .DeviceType = "CDAudio" .TimeFormat = 10 .Command = "Open" ' i secondi sono memorizzati nel byte più significativo Value = (.Length \ 256) And 255 TotalTime = Right$("0" & CStr(Value), 2) & """" ' i minuti sono memorizzati nel byte meno significativo Value = (.Length And 255) Mod 60 TotalTime = Right$("0" & CStr(Value), 2) & "' " & TotalTime Value = (.Length And 255) \ 60 If Value > 0 Then ' visualizza la durata solo se necessario TotalTime = CStr(Value) & "h " & TotalTime End If MsgBox TotalTime End With End Sub

Capitolo 15 - Le funzioni API di Windows Determinare l'utilizzo della memoria  Private Type MEMORYSTATUS dwLength As Long dwMemoryLoad As Long dwTotalPhys As Long dwAvailPhys As Long dwTotalPageFile As Long dwAvailPageFile As Long dwTotalVirtual As Long dwAvailVirtual As Long End Type Private Declare Sub GlobalMemoryStatus Lib "kernel32" Alias "GlobalMemoryStatus" _ (lpBuffer As MEMORYSTATUS) Sub ShowMemory() Dim ms As MEMORYSTATUS Dim msg As String ' richiede i dati in memoria ms.dwLength = Len(ms) GlobalMemoryStatus ms ' crea un messaggio per il risultato. msg = "Total physical memory = " & GetKbytes(ms.dwTotalPhys) & vbCrLf & "Available physical memory = " & GetKbytes(ms.dwAvailPhys) & vbCrLf "Memory Load = " & ms.dwMemoryLoad & "%" & vbCrLf & _ "Total Page file = " & GetKbytes(ms.dwTotalPageFile) & vbCrLf & _ "Available Page file = " & GetKbytes(ms.dwAvailPageFile) & vbCrLf & "Total Virtual memory = " & GetKbytes(ms.dwTotalVirtual) & vbCrLf & "Available Virtual memory = " & GetKbytes(ms.dwAvailVirtual) MsgBox msg, vbInformation, "Memory information" End Sub

_ & _ _ _

' formatta una certa quantità di memoria come Kbyte o Megabyte Function GetKbytes(ByVal amount As Long) As String ' converte in Kbyte amount = amount \ 1024 GetKbytes = Format(amount, "###,###,###K") End Function

Verificare la disponibilità di una porta seriale o parallela  ' Verifica se una data porta seriale COM è disponibile Function IsComPortAvailable(ByVal portNum As Integer) As Boolean Dim fnum As Integer On Error Resume Next fnum = FreeFile Open "COM" & CStr(portNum) For Binary Shared As #fnum If Err = 0 Then Close #fnum IsComPortAvailable = True End If End Function ' Verifica se una data porta parallela LPT è disponibile Function IsLptPortAvailable(ByVal portNum As Integer) As Boolean Dim fnum As Integer On Error Resume Next fnum = FreeFile Open "LPT" & CStr(portNum) For Binary Shared As #fnum If Err = 0 Then Close #fnum IsLptPortAvailable = True End If End Function

Estrarre stringhe ASCIIZ restituite da chiamate alla API di  Windows  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 WM_GETTEXT = &HD Dim buffer As String, i As Long, winText As String buffer = Space$(512)

SendMessage hWnd, WM_GETTEXT, Len(buffer), ByVal buffer i = Instr(buffer, vbNullChar) If i Then ' elimina i caratteri in eccesso winText = Left$(winText, i - 1) Else ' si è verificato un errore winText = "" End If

Determinare se una funzione API è disponibile  Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal _ lpLibFileName As String) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _ ByVal lpProcName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) _ As Long Function IsProcedureAvailable(ByVal ProcedureName As String, _ ByVal DllFilename As String) As Boolean Dim hModule As Long, procAddr As Long ' innanzitutto, tenta di caricare il modulo hModule = LoadLibrary(DllFilename) If hModule Then ' quindi, estrae l'indirizzo della routine procAddr = GetProcAddress(hModule, ProcedureName) ' infine, decrementa il contatore di utilizzo della DLL FreeLibrary hModule End If ' se procAddr è diverso da zero, la funzione è disponibile IsProcedureAvailable = (procAddr <> 0) End Function

Visualizzare la finestra di dialogo per configurare una porta  Private Declare Function ConfigurePort Lib "winspool.drv" Alias _ "ConfigurePortA" (ByVal pName As String, ByVal hWnd As Long, _ ByVal pPortName As String) As Long ' visualizza la finestra di dialogo per la configurazione delle porte seriali If ConfigurePort(vbNullString, 0&, "COM1:") = Then MsgBox "Unable to display the system dialog", vbCritical End If ' visualizza la finestra di dialogo per la configurazione delle porte parallele If ConfigurePort(vbNullString, 0&, "LPT1:") = Then MsgBox "Unable to display the system dialog", vbCritical End If

Creare una utility per ottenere informazioni su una window  Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _ (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal _ hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Dim Dim Dim Dim Dim

Sub Timer1_Timer() lpPoint As POINTAPI wndHandle As Long wndCaption As String wndClass As String length As Long

' ottiene la posizione del cursore del mouse GetCursorPos lpPoint ' ottiene l'handle della finestra che si trova sotto il cursore del mouse wndHandle = WindowFromPoint(lpPoint.x, lpPoint.y) ' ottiene il titolo/testo della finestra wndCaption = Space$(256) length = GetWindowText(wndHandle, wndCaption, Len(wndCaption)) wndCaption = Left$(wndCaption, length) ' ottiene la classe della finestra wndClass = Space$(256) length = GetClassName(wndHandle, wndClass, Len(wndClass)) wndClass = Left$(wndClass, length)

' visualizza il risultato nell'etichetta Label1 = "[" & Hex$(wndHandle) & "] " & wndClass & IIf(Len(wndCaption), _ " - """ & wndCaption & """", "") End Sub

Realizzare effetti speciali con i cursori animati  Private Declare Function LoadCursorFromFile Lib "user32" Alias _ "LoadCursorFromFileA" (ByVal lpFileName As String) As Long Private Declare Function GetCursor Lib "user32" () As Long Private Declare Function CopyIcon Lib "user32" (ByVal hcur As Long) As Long Private Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, _ ByVal id As Long) As Long Private Const OCR_NORMAL = 32512 Sub ALengthyTask() Dim hNewCursor As Long Dim hSavCursor As Long ' crea una copia del cursore corrente – questo è necessario ' affinchè il codice funzioni correttamente sotto NT hSavCursor = CopyIcon(GetCursor()) ' carica un nuovo cursore hNewCursor = LoadCursorFromFile("h:\winnt4\cursors\appstart.ani") ' lo rende il cursore corrente SetSystemCursor hNewCursor, OCR_NORMAL ' inserire qui il codice che richiede una lunga esecuzione ' ... ' (in questo esempio verrà utilizzata una casella di messaggio) MsgBox "Press OK to continue" ' ripristina il vecchio cursore SetSystemCursor hSavCursor, OCR_NORMAL End Sub

Determinare se un programma è a 16 o a 32 bit  Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * szTypeName As String * 80 End Type Const WIN32_GUI = &H4550 ' Const WIN16_GUI = &H454E ' Const WIN16_DOS = &H5A4D ' Const SHGFI_EXETYPE = &H2000

MAX_PATH PE, Win32 NE, Win16 MZ, MS-DOS

Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _ ( ByVal pszPath As String, ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long ) As _ Long dw = SHGetFileInfo(exename, 0, sfi, Len(sfi), SHGFI_EXETYPE) lowWord = dw And &H7FFF

Disabilitare la combinazione di tasti Ctrl-Alt-Del in Windows  9x  Private Const SPI_SETSCREENSAVERRUNNING = 97 Private Declare Function SystemParametersInfo Lib "user32" Alias _ "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _ ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long ' disabilita la combinazione di tasti Ctrl-Alt-Del SystemParametersInfo SPI_SETSCREENSAVERRUNNING, True, ByVal 0&, 0 ' .... ' la riabilita SystemParametersInfo SPI_SETSCREENSAVERRUNNING, False, ByVal 0&, 0

Determinare la modalità di avvio di Windows  Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) _ As Long Public Const SM_CLEANBOOT = 67 Private Sub Command1_Click() Select Case GetSystemMetrics(SM_CLEANBOOT) Case 0: MsgBox "Normal boot"

Case 1: MsgBox "Fail-safe boot" Case 2: MsgBox "Fail-safe with network boot" End Select End Sub

Determinare la versione di Windows richiesta da un  determinato programma  Type SHFILEINFO hIcon As Long iIcon As Long dwAttributes As Long szDisplayName As String * MAX_PATH szTypeName As String * 80 End Type Public Const SHGFI_EXETYPE = &H2000 Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _ ( ByVal pszPath As String, ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long ) As _ Long dw = SHGetFileInfo(exename, 0, sfi, Len(sfi), SHGFI_EXETYPE) hiWord = dw \ &H10000

Ottenere il codice d'uscita di un processo  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As _ Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As _ Long, lpExitCode As Long) As Long Const STILL_ACTIVE = &H103 Const PROCESS_QUERY_INFORMATION = &H400 Private Dim Dim Dim

Sub cmdRunNotepad_Click() hTask As Long hProcess As Long exitCode As Long

hTask = Shell("Notepad", vbNormalFocus) hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hTask) ' cicla fino a che il processo restituisce un codice d'uscita valido Do ' rinuncia a questo intervallo di tempo della CPU Sleep 100 DoEvents ' richiede il codice d'uscita GetExitCodeProcess hProcess, exitCode Loop While exitCode = STILL_ACTIVE MsgBox "Exit code = " & exitCode, vbInformation End Sub

Stabilire quando l'applicazione ottiene o perde il focus di  input  ' Richiede un riferimento alla libreria MSGHOOKX.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' è possibile omettere la costante che segue, in quanto è ' definita nella type library MsgHookX Const WM_ACTIVATEAPP = &H1C Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' esegue il subclassing degli eventi della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) If uMsg = WM_ACTIVATEAPP Then If wParam Then ' l'applicazione è stata attivata Else

' l'applicazione è stata disattivata End If End If End Sub

Nascondere o disabilitare le icone del desktop  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _ lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, _ ByVal wCmd As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, _ ByVal fEnable As Long) As Long Private Const GW_CHILD = 5 Private Const SW_HIDE = 0 Private Const SW_SHOW = 5 Sub ShowDesktopIcons(ByVal bVisible As Boolean) Dim hWnd_DesktopIcons As Long hWnd_DesktopIcons = GetWindow( FindWindow("Progman", "Program Manager"), _ GW_CHILD) If bVisible Then ShowWindow hWnd_DesktopIcons, SW_SHOW Else ShowWindow hWnd_DesktopIcons, SW_HIDE End If End Sub Sub EnableDesktop(ByVal bEnable As Boolean) Dim hWnd_Desktop As Long hWnd_Desktop = GetWindow( FindWindow("Progman", "Program Manager"), _ GW_CHILD) If bEnable Then EnableWindow hWnd_Desktop, True Else EnableWindow hWnd_Desktop, False End If End Sub '

versione più compatta

Sub ShowDesktopIcons(ByVal bVisible As Boolean) ShowWindow GetWindow( FindWindow("Progman", "Program Manager"), GW_CHILD), _ IIf(bVisible, SW_SHOW, SW_HIDE) End Sub Sub EnableDesktop(ByVal bEnable As Boolean) EnableWindow GetWindow( FindWindow("Progman", "Program Manager"), GW_CHILD), _ bEnable End Sub

Nascondere o disabilitare la barra delle applicazioni di  Windows  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _ lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, _ ByVal fEnable As Long) As Long Private Const SW_HIDE = 0 Private Const SW_SHOW = 5 Sub ShowStartBar(ByVal bVisible As Boolean) Dim hWnd_StartBar As Long hWnd_StartBar = FindWindow("Shell_TrayWnd", "") If bVisible Then ShowWindow hWnd_StartBar, SW_SHOW Else ShowWindow hWnd_StartBar, SW_HIDE End If End Sub Sub EnableStartBar(ByVal bEnable As Boolean) Dim hWnd_StartBar As Long hWnd_StartBar = FindWindow("Shell_TrayWnd", "") If bEnable Then EnableWindow hWnd_StartBar, True Else EnableWindow hWnd_StartBar, False End If End Sub

'

versione più compatta

Sub ShowStartBar(ByVal bVisible As Boolean) ShowWindow FindWindow("Shell_TrayWnd", ""), IIf(bVisible, SW_SHOW, SW_HIDE) End Sub Sub EnableStartBar(ByVal bEnable As Boolean) EnableWindow FindWindow("Shell_TrayWnd", ""), bEnable End Sub

Aprire il Pannello di controllo o una procedura guidata  Public Enum mbDialogType mbNewHardware mbAddRemove mbDateTimeProp mbDisplayProp mbInternetProp mbGameProp mbKeyboardProp mbModemProp mbMouseProp mbMultimediaProp mbNetworkProp mbPasswordProp mbInternationalProp mbSoundProp mbSystemProp End Enum Sub OpenWindowsDialog(ByVal mbDialog As mbDialogType) Dim s As String Select Case mbDialog Case mbNewHardware: s = "sysdm.cpl @1" Case mbAddRemove: s = "appwiz.cpl,,1" Case mbDateTimeProp: s = "timedate.cpl" Case mbDisplayProp: s = "desk.cpl,,0" Case mbInternetProp: s = "inetcpl.cpl,,0" Case mbGameProp: s = "joy.cpl" Case mbKeyboardProp: s = "main.cpl @1" Case mbModemProp: s = "modem.cpl" Case mbMouseProp: s = "main.cpl @0" Case mbMultimediaProp: s = "mmsys.cpl,,0" Case mbNetworkProp: s = "netcpl.cpl" Case mbPasswordProp: s = "password.cpl" Case mbInternationalProp: s = "intl.cpl,,0" Case mbSoundProp: s = "mmsys.cpl @1" Case mbSystemProp: s = "sysdm.cpl,,0" End Select Shell "rundll32.exe shell32.dll,Control_RunDLL " & s, 5 End Sub

Aprire il prompt di MS-DOS da qualsiasi directory all'interno  di Windows Explorer  REGEDIT4 [HKEY_CLASSES_ROOT\Directory\Shell\DosPrompt] @="Run MS-DOS Prompt here" [HKEY_CLASSES_ROOT\Directory\Shell\DosPrompt\Command] @="Cmd /k CD \"%L\" "

Attivare il menu Start di Windows via codice  Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _ ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Const KEYEVENTF_KEYUP = &H2 ' simula la pressione dei tasti Ctrl-Esc keybd_event vbKeyControl, 0, 0, 0 keybd_event vbKeyEscape, 0, 0, 0 DoEvents ' simula il rilascio dei due tasti keybd_event vbKeyControl, 0, KEYEVENTF_KEYUP, 0 keybd_event vbKeyEscape, 0, KEYEVENTF_KEYUP, 0 DoEvents

Restituire un codice d'errore Dos in uscita  REM a Ms-Dos batch file CD c:\MyApp

Text.Exe If Errorlevel 2 Goto ExitCodeIsTwo If Errorlevel 1 Goto ExitCodeIsOne REM process here a null exit code REM ... GOTO EndBatch :ExitCodeTwo REM process here exit code equals to two REM ... GOTO EndBatch :ExitCodeOne REM process here exit code equals to one REM ... :EndBatch ECHO goodbye.

Effettuare una chiamata telefonica utilizzando TAPI  Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As _ String, ByVal AppName As String, ByVal CalledParty As String, _ ByVal Comment As String) As Long ' effettua una chiamata telefonica utilizzando TAPI ' restituisce True in caso di successo Function PhoneCall(ByVal PhoneNumber As String, ByVal DestName As String, _ Optional ByVal Comment As String) As Boolean If tapiRequestMakeCall(Trim$(PhoneNumber), App.Title, Trim$(DestName), _ Comment) = 0 Then PhoneCall = True End If End Function

Creare un'icona per la System Tray di Windows  Type NOTIFYICONDATA cbSize As Long ' dimensioni della struttura hwnd As Long ' handle della finestra padre uId As Long ' utilizzato solo con più icone associate ' alla medesima applicazione uFlags As Long ' Flag uCallBackMessage As Long ' gestore delle notifiche hIcon As Long ' handle dell'icona szTip As String * 64 ' testo del tooltip End Type Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _ (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean Const NIM_ADD = &H0 ' Aggiunge un'icona Const NIM_MODIFY = &H1 ' Modifica un'icona Const NIM_DELETE = &H2 ' Elimina un'icona Const NIF_MESSAGE = &H1 Const NIF_ICON = &H2 Const NIF_TIP = &H4 Const Const Const Const Const

WM_MOUSEMOVE = &H200 WM_LBUTTONDOWN = &H201 WM_LBUTTONDBLCLK = &H203 WM_RBUTTONDOWN = &H204 WM_RBUTTONDBLCLK = &H206

' Per modificare il membro uCallBackMessage ' Per modificare l'icona ' Per modificare il testo del tooltip ' ' ' '

Clic con il Doppio clic Clic con in Doppio clic

tasto sinistro con il tasto sinistro tasto destro con il tasto destro

Dim nid As NOTIFYICONDATA Private Sub Form_Load() nid.cbSize = Len(nid) nid.hwnd = Form1.hwnd nid.uId = 0 nid.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE nid.uCallBackMessage = WM_MOUSEMOVE nid.hIcon = Form1.Icon ' Chr$(0) è necessario alla fine della stringa nid.szTip = "Hello World" + vbNullChar Shell_NotifyIcon NIM_ADD, nid End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) Dim Msg As Long Msg = ScaleX(X, ScaleMode, vbPixels)

Select Case Msg Case WM_LBUTTONDOWN MsgBox "Left click!" Case WM_LBUTTONDBLCLK MsgBox "Left double-click!" Case WM_RBUTTONDOWN MsgBox "Right click!" Case WM_RBUTTONDBLCLK MsgBox "Right double-click!" End Select End Sub Private Sub cmdChangeTooltip() nid.szTip = "A new tooltip text" & vbNullChar Shell_NotifyIcon NIM_MODIFY, nid End Sub Private Sub Form_Unload(Cancel As Integer) Shell_NotifyIcon NIM_DELETE, nid End Sub

Tracciare le modifiche alla data/ora del sistema ed alla  risoluzione dello schermo  ' Richiede un riferimento alla libreria MSGHOOK.DLL,che può essere scaricata dal seguente URL: ' http://www.vb2themax.com/Downloads/Files/MsgHook.zip ' è possibile omettere le seguenti definizioni di costanti, ' in quanto risultano definite nella type library MsgHookX Const WM_TIMECHANGE = &H1E Const WM_DISPLAYCHANGE = &H7E Const WM_COMPACTING = &H41 Dim WithEvents FormHook As MsgHook Private Sub Form_Load() ' inizia il subclassing degli eventi della form Set FormHook = New MsgHook FormHook.StartSubclass hWnd End Sub Private Sub FormHook_AfterMessage(ByVal uMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long, retValue As Long) Select Case uMsg Case WM_DISPLAYCHANGE ' la risoluzione dello schermo è stato modificata. ' ... ' ... (aggiungere in questo punto la procedura per ridimensionare le form) ... ' ... Case WM_TIMECHANGE ' la data e l'ora del sistema sono state modificate. ' ... Case WM_COMPACTING ' Windows è a corto di memoria (rilascia le risorse se possibile). ' ... ' ... (rilascia il maggior numero di risorse possibile) ... ' ... End Select End Sub

Utilizzare valori Currency invece di LARGE_INTEGER nelle  chiamate API  Private Declare Function GetDiskFreeSpaceEx2 Lib "kernel32" Alias _ "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _ lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, _ lpTotalNumberOfFreeBytes As Currency) As Long Dim lpFreeBytesAvailableToCaller As Currency Dim lpTotalNumberOfBytes As Currency Dim lpTotalNumberOfFreeBytes As Currency GetDiskFreeSpaceEx2 "C:\", lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, _ LpTotalNumberOfFreeBytes ' eliminare le quattro cifre decimali dai risultati Debug.Print "Free Bytes Available to Caller = " & lpFreeBytesAvailableToCaller * 10000# Debug.Print "Total Number of Bytes = " & lpTotalNumberOfBytes * 10000# Debug.Print "Total Number of Free Bytes = " & lpTotalNumberOfFreeBytes * 10000#

Capitolo 16 - Applicazioni Internet Creare uno shortcut per Internet  ' ' ' ' '

Crea uno shortcut per Internet quando selezionato con un doppio clic, questo shortcut caricherà il browser predefinito e farà in modo che questo punti alla pagina relativa all'URL specificato

Sub CreateInternetShortcut(ByVal FileName As String, ByVal URL As String) Dim fnum As Integer ' uno shortcut per Internet è semplicemente un file di testo di due righe fnum = FreeFile Open FileName For Output As #fnum Print #fnum, "[InternetShortcut]" Print #fnum, "URL=" & URL Close #fnum End Sub

Verificare la validità di un URL Private Declare Function IsValidURL Lib "urlmon" (ByVal pBC As Long, _ url As Byte, ByVal dwReserved As Long) As Long Dim url As String Dim b() As Byte url = "http://www.vb2themax.com/default.asp" ' Questo è necessario in quanto viene passata una stringa Unicode b = url & vbNullChar If IsValidURL(0, b(0), 0) = 0 Then ' URL valido Else ' URL non valido End If

Verificare che il RAS sia installato  Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef _ lpdwFalgs As Long, ByVal dwReserved As Long) As Boolean Const INTERNET_RAS_INSTALLED = 16 ' controlla se il RAS è stato installato Function IsRASInstalled() As Boolean Dim connStatus As Long InternetGetConnectedState connStatus, 0& IsRASInstalled = (connStatus And INTERNET_RAS_INSTALLED) End Function

Verificare se esiste una connessione ad Internet  Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef _ lpSFlags As Long, ByVal dwReserved As Long) As Long Const INTERNET_CONNECTION_MODEM = 1 Const INTERNET_CONNECTION_LAN = 2 Const INTERNET_CONNECTION_PROXY = 4 Const INTERNET_CONNECTION_MODEM_BUSY = 8 Dim flags As Long If InternetGetConnectedState(flags, 0) = 0 Then ' nessuna connessione attiva ElseIf flags = INTERNET_CONNECTION_MODEM Then ' connessione attiva via modem ElseIf flags = INTERNET_CONNECTION_LAN Then ' connessione attiva via LAN ElseIf flags = INTERNET_CONNECTION_PROXY Then ' connessione attiva via proxy End If

Verificare se l'utente lavora off-line  Const INTERNET_OPTION_CONNECTED_STATE = 50 Const INTERNET_STATE_DISCONNECTED_BY_USER = &H10 Private Type INTERNET_CONNECTED_INFO dwConnectedState As Long

dwFlags As Long End Type Private Declare Function InternetQueryOption Lib "wininet.dll" Alias _ "InternetQueryOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, _ lpBuffer As INTERNET_CONNECTED_INFO, lpdwBufferLength As Long) As Boolean ' Restituisce True se l'utente lavora off-line Function IsWorkingOffLine() As Boolean Dim dwState As Long, dwSize As Long Dim ci As INTERNET_CONNECTED_INFO dwState = 0 dwSize = LenB(dwState) If InternetQueryOption(0&, INTERNET_OPTION_CONNECTED_STATE, ci, dwSize) Then IsWorkingOffLine = (ci.dwConnectedState And _ INTERNET_STATE_DISCONNECTED_BY_USER) End If End Function

Eseguire il download di un file  Private Declare Function URLDownloadToFile Lib "urlmon" Alias _ "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _ ByVal szFileName As String, ByVal dwReserved As Long, _ ByVal lpfnCB As Long) As Long ' Questo file è di 2MB, pertanto si potrebbe voler tentare con qualcosa di più semplice Dim errcode As Long Dim url As String Dim localFileName As String url = "http://www.vb2themax.com/vbmaximizer/files/vbm_demo.zip" localFileName = "c:\vbm_demo.zip" errcode = URLDownloadToFile(0, url, localFileName, 0, 0) If errcode = 0 Then MsgBox "Download ok" Else MsgBox "Error while downloading" End If

Lanciare il browser predefinito caricando un determinato URL 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 ' Apre il browser predefinito caricando un determinato URL ' Restituisce True in caso di successo, altrimenti False Public Function OpenBrowser(ByVal URL As String) As Boolean Dim res As Long ' l'URL deve obbligatoriamente contenere il prefisso http:// o https:// If InStr(1, URL, "http", vbTextCompare) <> 1 Then URL = "http://" & URL End If res = ShellExecute(0&, "open", URL, vbNullString, vbNullString, _ vbNormalFocus) OpenBrowser = (res > 32) End Function

Aprire il programma predefinito per inviare messaggi di posta  elettronica  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 ' Apre il programma predefinito per l'invio dei messaggi di posta elettronica ' Restituisce True in caso di successo, altrimenti False Public Function OpenEmailProgram(ByVal EmailAddress As String) As Boolean Dim res As Long res = ShellExecute(0&, "open", "mailto:" & EmailAddress, vbNullString, _ vbNullString, vbNormalFocus) OpenEmailProgram = (res > 32)

End Function

Impostare la modalità off-line  Const Const Const Const Const Const Const

INTERNET_OPTION_CONNECTED_STATE = 50 INTERNET_STATE_CONNECTED = 1 INTERNET_STATE_DISCONNECTED = 2 INTERNET_STATE_DISCONNECTED_BY_USER = &H10 INTERNET_STATE_IDLE = &H100 INTERNET_STATE_BUSY = &H200 ISO_FORCE_DISCONNECTED = 1

Private Declare Function InternetSetOption Lib "wininet.dll" Alias _ "InternetSetOptionA" (ByVal hInternet As Long, ByVal dwOption As Long, _ lpBuffer As INTERNET_CONNECTED_INFO, ByVal dwBufferLength As Long) As _ Boolean ' Applica le modalità OffLine o OnLine Sub SetOffLineMode(ByVal offLineMode As Boolean) Dim ci As INTERNET_CONNECTED_INFO Dim retValue As Boolean If offLineMode Then ci.dwConnectedState = INTERNET_STATE_DISCONNECTED_BY_USER ci.dwFlags = ISO_FORCE_DISCONNECTED Else ci.dwConnectedState = INTERNET_STATE_CONNECTED End If retValue = InternetSetOption(0&, INTERNET_OPTION_CONNECTED_STATE, ci, _ LenB(ci)) If retValue = False Then Err.Raise vbObjectError + 1000, , _ "An error occurred calling SetOffLineMode function" End Sub

Aggiungere un URL ai favoriti di Internet Explorer  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 Sub AddToIEFavorites(ByVal sURL As String, ByVal sDescr As String) sURL = LCase(sURL) ' aggiungere http:// se mancante If Left$(sURL, 7) <> "http://" Then sURL = "http://" & sURL ' apri IE ed esegui lo script ShellExecute 0, "Open", "javascript:window.external.AddFavorite('" & sURL & _ "','" & sDescr & "')", "", "", 0 End Sub

Convertire una stringa in HTML Function HTMLEncode(ByVal Text As String) As String Dim i As Integer Dim acode As Integer Dim repl As String HTMLEncode = Text For i = Len(HTMLEncode) To 1 Step -1 acode = Asc(Mid$(HTMLEncode, i, 1)) Select Case acode Case 32 repl = " " Case 34 repl = """ Case 38 repl = "&" Case 60 repl = "<" Case 62 repl = ">" Case 32 To 127 ' non modificare i caratteri alfanumerici Case Else repl = "&#" & CStr(acode) & ";" End Select If Len(repl) Then HTMLEncode = Left$(HTMLEncode, i - 1) & repl & Mid$(HTMLEncode, _ i + 1) repl = "" End If Next

End Function Function HTMLDecode(ByVal html As String) As String Dim i As Long HTMLDecode = html Do ' ricerca il carattere & successivo, esci se non ce ne sono i = InStr(i + 1, HTMLDecode, "&") If i = 0 Then Exit Do ' controlla se si tratta di un carattere speciale If StrComp(Mid$(HTMLDecode, i, 6), " ", vbTextCompare) = 0 Then HTMLDecode = Left$(HTMLDecode, i - 1) & " " & Mid$(HTMLDecode, _ i + 6) ElseIf StrComp(Mid$(HTMLDecode, i, 6), """, vbTextCompare) = 0 Then HTMLDecode = Left$(HTMLDecode, i - 1) & """" & Mid$(HTMLDecode, _ i + 6) ElseIf StrComp(Mid$(HTMLDecode, i, 5), "&", vbTextCompare) = 0 Then HTMLDecode = Left$(HTMLDecode, i - 1) & "&" & Mid$(HTMLDecode, _ i + 5) ElseIf StrComp(Mid$(HTMLDecode, i, 4), "<", vbTextCompare) = 0 Then HTMLDecode = Left$(HTMLDecode, i - 1) & "<" & Mid$(HTMLDecode, _ i + 4) ElseIf StrComp(Mid$(HTMLDecode, i, 4), ">", vbTextCompare) = 0 Then HTMLDecode = Left$(HTMLDecode, i - 1) & ">" & Mid$(HTMLDecode, _ i + 4) End If Loop End Function