[Collection] Source Codes VB6 09-18-2011, 04:01 PM
#1
Use API To See If Windows Started In Safe Mode
Create PDF in VB Source Code
Drag and Drop With List Box
Simple way to store strings in the Registry
Convert HTML Color to RGB
Fancy Collapsing Form Exit
Replace Text in a TextBox
Count the number of words in a textbox
Remove an element from an array
Launch a program from VB
Copy a File Quickly
Code:
Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Public Const SM_CLEANBOOT = 67
No go to your main form, add a command button, double click on the button to go to its click event handler, and add the following code.
Select Case GetSystemMetrics(SM_CLEANBOOT)
Case 1: MsgBox "Windows was Started in Safe Mode."
Case 2: MsgBox _
"Windows was Started in Safe Mode with Network support."
Case Else: MsgBox "Windows is running normally."
End SelectCreate PDF in VB Source Code
Drag and Drop With List Box
Code:
Dim ItemCount As Integer
Dim I As Integer
On Error Resume Next
ItemCount = Data.Files.Count
For I = 1 To ItemCount
List1.AddItem Data.Files(I)
Next
If Err Then Err.ClearSimple way to store strings in the Registry
Code:
Private Sub Command1_Click()
SaveSetting "MyString", "New", "Test", Text1.Text
End Sub
Private Sub Command2_Click()
Text2.Text = GetSetting("MyString", "New", _
"Test", vbNullString)
End Sub
Private Sub Form_Load()
Text1.Text = "This is a Test"
Command1.Caption = "Write Value"
Command2.Caption = "Read Value"
End SubConvert HTML Color to RGB
Code:
Function HTMLtoRGB(HtmlCode As String) As String
If Left(HtmlCode, 1) = "#" Then
HtmlCode = Right(HtmlCode, 6)
End If
RED = Left(HtmlCode, 2)
GREEN = Mid(HtmlCode, 3, 2)
BLUE = Right(HtmlCode, 2)
RgbHex = "&H00" + BLUE + GREEN + RED
HTMLtoRGB = "&" & Val(RgbHex)
End Function
Private Sub Command1_Click()
MsgBox HTMLtoRGB("0000FF")
End SubFancy Collapsing Form Exit
Code:
Do While Me.Width > 1800
Me.Width = Me.Width - 300
Me.Left = Me.Left + 150
If Me.Height - 400 Then
Me.Top = Me.Top - 1
Me.Height = Me.Height - 150
End If
Loop
Unload Form1: EndReplace Text in a TextBox
Code:
Dim StartPos, Counter As Integer
Dim FindString, ReplaceText As String
FindString = "test"
ReplaceText = "MyString"
For Counter = 1 To Len(Text1.Text)
StartPos = InStr(Text1.Text, FindString)
If StartPos > 0 Then
Text1.SelStart = StartPos - 1
Text1.SelLength = Len(FindString)
Text1.SelText = "" + ReplaceText
End If
NextCount the number of words in a textbox
Code:
Dim Counter As Integer
Dim StartPos As Integer
If Trim(Text1) = "" Then
NumOfWords = 0
Exit Sub
End If
Text1 = Trim(Text1) ' Remove All Spaces
While InStr(1, Text1, " ") > 0 'Remove Double Spaces
StartPos = InStr(1, Text1, " ")
Text1 = Mid(Text1, 1, StartPos - 1) & _
Mid(Text1, StartPos + 1, Len(Text1) - StartPos)
Wend
NumOfWords = 1
For Counter = 1 To Len(Text1)
If Mid(Text1, Counter, 1) = " " Then
NumOfWords = NumOfWords + 1
End If
Next Counter
MsgBox "Found " & NumOfWords & " Words"Remove an element from an array
Code:
Private Type my_type
field1 As String
field2 As Long
field3 As Integer
End Type
Const MAX_ARRAY = 10
Dim strBuffer(0 To MAX_ARRAY - 1) As my_type
Public Sub DeleteRecordFromMyArray(RecPos As Integer, MaxRecs As Integer)
Dim I As Integer
For I = RecPos To MaxRecs - 1
strBuffer(I) = strBuffer(I + 1)
Next
strBuffer(MaxRecs).field1 = ""
strBuffer(MaxRecs).field2 = 0
strBuffer(MaxRecs).field3 = 0
End SubLaunch a program from VB
Code:
Dim Res
Dim Filename
Filename = "C:\windows\notepad.exe" 'Check file is here first
If Dir(Filename) = "" Then
MsgBox Filename & " not found", vbInformation
Else
Res = Shell("Start.exe " & Filename, vbHide)
End IfCopy a File Quickly
Code:
Dim mByte() As Byte
Open "C:\Command.com" For Binary As #1
Open "C:\Backup.com" For Binary As #2
ReDim mByte(0 To LOF(1))
Get #1, , mByte()
Put #2, , mByte()
Close #1
Close #2
MsgBox "Done", vbInformation

![[+]](https://sinister.li/images/modern/collapse_collapsed.png)