Code:
Option Explicit
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageByString Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare Function SendMessageLong& Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Public Declare Function SendMessageByNum& Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Public Const LB_ADDSTRING& = &H180
Public Const LB_DELETESTRING = &H182
Public Const LB_FINDSTRINGEXACT& = &H1A2
Public Const LB_GETCOUNT& = &H18B
Public Const LB_GETCURSEL& = &H188
Public Const LB_GETITEMDATA = &H199
Public Const LB_GETTEXT = &H189
Public Const LB_GETTEXTLEN& = &H18A
Public Const LB_INSERTSTRING = &H181
Public Const LB_RESETCONTENT& = &H184
Public Const LB_SETHORIZONTALEXTENT = &H194
Public Const LB_SETSEL = &H185
'-----------------------------------------------
Public Sub UCASEList(TheListBox As LISTBOX)
Dim TempNumber As String
TempNumber = 0
While TempNumber < TheListBox.ListCount
TheListBox.List(TempNumber) = UCase(TheListBox.List(TempNumber))
TempNumber = Val(TempNumber) + Val(1)
Wend
End Sub
Public Sub LCASEList(TheListBox As LISTBOX)
Dim TempNumber As String
TempNumber = 0
While TempNumber < TheListBox.ListCount
TheListBox.List(TempNumber) = LCase(TheListBox.List(TempNumber))
TempNumber = Val(TempNumber) + Val(1)
Wend
End Sub
Public Sub ReplaceInList(TheListBox As LISTBOX, WhatToReplace As String, ReplaceWith As String)
Dim TempNumber As String
TempNumber = 0
While TempNumber < TheListBox.ListCount
TheListBox.List(TempNumber) = Replace(TheListBox.List(TempNumber), WhatToReplace, ReplaceWith)
TempNumber = Val(TempNumber) + Val(1)
Wend
End Sub
Public Sub ConfirmClear(LISTBOX As LISTBOX)
If MsgBox("Are you sure you want to clear this list?", vbYesNo, "Confirmation") = vbYes Then
LISTBOX.Clear
End If
End Sub
Public Sub xListKillDupes(LISTBOX As LISTBOX)
'Kills dublicite items in a listbox
Dim Search1 As Long
Dim Search2 As Long
Dim KillDupe As Long
KillDupe = 0
For Search1& = 0 To LISTBOX.ListCount - 1
For Search2& = Search1& + 1 To LISTBOX.ListCount - 1
KillDupe = KillDupe + 1
If LISTBOX.List(Search1&) = LISTBOX.List(Search2&) Then
LISTBOX.RemoveItem Search2&
Search2& = Search2& - 1
End If
Next Search2&
Next Search1&
End Sub
Public Function xListToTextString(LISTBOX As LISTBOX, InsertSeparator As String) As String
'Makes list a txt string
Dim CurrentCount As Long, PrepString As String
For CurrentCount& = 0 To LISTBOX.ListCount - 1
PrepString$ = PrepString$ & LISTBOX.List(CurrentCount&) & InsertSeparator$
Next CurrentCount&
xListToTextString$ = Left(PrepString$, Len(PrepString$) - 2)
End Function
Public Sub xListCopy(SourceList As Long, DestinationList As Long)
'Copys a list to another
'Call ListCopy ("list1", "List2")
Dim SourceCount As Long, OfCountForIndex As Long, FixedString As String
SourceCount& = SendMessageLong(SourceList&, LB_GETCOUNT, 0&, 0&)
Call SendMessageLong(DestinationList&, LB_RESETCONTENT, 0&, 0&)
If SourceCount& = 0& Then Exit Sub
For OfCountForIndex& = 0 To SourceCount& - 1
FixedString$ = String(250, 0)
Call SendMessageByString(SourceList&, LB_GETTEXT, OfCountForIndex&, FixedString$)
Call SendMessageByString(DestinationList&, LB_ADDSTRING, 0&, FixedString$)
Next OfCountForIndex&
End Sub
Public Function xListGetText(LISTBOX As Long, Index As Long) As String
Dim ListText As String * 256
Call SendMessageByString(LISTBOX&, LB_GETTEXT, Index&, ListText$)
xListGetText$ = ListText$
End Function
Public Sub xListRemoveSelected(LISTBOX As LISTBOX)
Dim ListCount As Long
ListCount& = LISTBOX.ListCount
Do While ListCount& > 0&
ListCount& = ListCount& - 1
If LISTBOX.Selected(ListCount&) = True Then
LISTBOX.RemoveItem (ListCount&)
End If
Loop
End Sub
Public Sub xLoad2listboxes(Path As String, List1 As LISTBOX, List2 As LISTBOX)
'Loads Two list boxes
Dim MyString As String, String1 As String, String2 As String
On Error Resume Next
Open Path$ For Input As #1
While Not EOF(1)
Input #1, MyString$
String1$ = Left(MyString$, InStr(MyString$, "*") - 1)
String2$ = Right(MyString$, Len(MyString$) - InStr(MyString$, "*"))
DoEvents
List1.AddItem String1$
List2.AddItem String2$
Wend
Close #1
End Sub
Public Function xListClickEvent()
'Have you ever wanted, on a listbox, that when a certain item is click, something
'happens, well, this is the coding for it
'Do not use this as in a module, but in the form, im just showing how its done.
'Private Sub List1_Click()
'If List1.List(List1.ListIndex) = "Source" Then
'MsgBox "You Click Source in List1"
'End If
'End Sub
End Function
Public Sub xSaveList(filename As String, List As LISTBOX)
'self explanatory
On Error Resume Next
Dim lngSave As Long
If filename$ = "" Then Exit Sub
Open filename$ For Output As #1
For lngSave& = 0 To List.ListCount - 1
Print #1, List.List(lngSave&)
Next lngSave&
Close #1
End Sub
Public Sub xLoadList(filename As String, List As LISTBOX)
'self explanatory
Dim lstInput As String
On Error Resume Next
Open filename$ For Input As #1
While Not EOF(1)
Input #1, lstInput$
'DoEvents
List.AddItem ReplaceText(lstInput$, "aol.com", "")
Wend
Close #1
End Sub
Public Function ReplaceText(tMain As String, tFind As String, tReplace As String) As String
'replaces a string within a larger string
Dim iFind As Long, lString As String, rString As String, rText As String, tMain2 As String
iFind& = InStr(1, LCase(tMain$), LCase(tFind$))
If iFind& = 0& Then ReplaceText = tMain$: Exit Function
Do
DoEvents
lString$ = Left(tMain$, iFind& - 1)
rString$ = Mid(tMain$, iFind& + Len(tFind$), Len(tMain$) - (Len(lString$) + Len(tFind$)))
tMain$ = lString$ + "" + tReplace$ + "" + rString$
iFind& = InStr(iFind& + Len(tReplace$), LCase(tMain$), LCase(tFind$))
If iFind& = 0& Then Exit Do
Loop
ReplaceText = tMain$
End Function
Public Sub SaveListBox(Directory As String, TheList As LISTBOX)
Dim savelist As Long
On Error Resume Next
Open Directory$ For Output As #1
For savelist& = 0 To TheList.ListCount - 1
Print #1, TheList.List(savelist&)
Next savelist&
Close #1
End Sub
Public Sub Loadlistbox(Directory As String, TheList As LISTBOX)
Dim MyString As String
On Error Resume Next
Open Directory$ For Input As #1
While Not EOF(1)
Input #1, MyString$
DoEvents
TheList.AddItem MyString$
Wend
Close #1
End Sub
Public Sub Load2Lists(ListSN As LISTBOX, ListPW As LISTBOX, Target As String)
'self explanatory
On Error Resume Next
Dim lstInput As String, strSN As String, strPW As String
If FileExists(Target$) = True Then
Open Target$ For Input As #1
While Not EOF(1) = True
'DoEvents
Input #1, lstInput$
If InStr(1, lstInput$, "]-[") <> 0& And InStr(1, lstInput$, "=") <> 0& Then
lstInput$ = Mid(lstInput$, InStr(1, lstInput$, "]-[") + 3, Len(lstInput$) - 6)
strSN$ = Left(lstInput$, InStr(1, lstInput$, "=") - 1)
strPW$ = Right(lstInput$, Len(lstInput$) - InStr(1, lstInput$, "="))
If Trim(strSN$) <> "" And Trim(strPW$) <> "" Then
ListSN.AddItem Trim(strSN$)
ListPW.AddItem Trim(strPW$)
End If
ElseIf InStr(1, lstInput$, ":") <> 0& Then
strSN$ = Left(lstInput$, InStr(1, lstInput$, ":") - 1)
strPW$ = Right(lstInput$, Len(lstInput$) - InStr(1, lstInput$, ":"))
If Trim(strSN$) <> "" And Trim(strPW$) <> "" Then
ListSN.AddItem Trim(strSN$)
ListPW.AddItem Trim(strPW$)
End If
ElseIf InStr(1, lstInput$, "-") Then
strSN$ = Left(lstInput$, InStr(1, lstInput$, "-") - 1)
strPW$ = Right(lstInput$, Len(lstInput$) - InStr(1, lstInput$, "-"))
If Trim(strSN$) <> "" And Trim(strPW$) <> "" Then
ListSN.AddItem Trim(strSN$)
ListPW.AddItem Trim(strPW$)
End If
ElseIf InStr(1, lstInput$, "=") Then
strSN$ = Left(lstInput$, InStr(1, lstInput$, "=") - 1)
strPW$ = Right(lstInput$, Len(lstInput$) - InStr(1, lstInput$, "="))
If Trim(strSN$) <> "" And Trim(strPW$) <> "" Then
ListSN.AddItem Trim(strSN$)
ListPW.AddItem Trim(strPW$)
End If
ElseIf InStr(1, lstInput$, "�") Then
strSN$ = Left(lstInput$, InStr(1, lstInput$, "�") - 1)
strPW$ = Right(lstInput$, Len(lstInput$) - InStr(1, lstInput$, "�"))
If Trim(strSN$) <> "" And Trim(strPW$) <> "" Then
ListSN.AddItem Trim(strSN$)
ListPW.AddItem Trim(strPW$)
End If
End If
Wend
Close #1
End If
End Sub
Public Sub Save2Lists(ListSN As LISTBOX, ListPW As LISTBOX, Target As String)
'self explanatory
Dim sLong As Long
On Error Resume Next
Open Target$ For Output As #1
For sLong& = 0 To ListSN.ListCount - 1
Print #1, "" + ListSN.List(sLong&) + ":" + ListPW.List(sLong&) + ""
Next sLong&
Close #1
End Sub
Public Function FileExists(TheFileName As String) As Boolean
'Sees if the string(file) you specified exists
If Len(TheFileName$) = 0 Then
FileExists = False
Exit Function
End If
If Len(Dir$(TheFileName$)) Then
FileExists = True
Else
FileExists = False
End If
End Function
Public Function ListBoxCheckDup(List As LISTBOX, Query As String) As Boolean
'knot n chichris
If Query = "" Then Exit Function
If Not TypeOf List Is LISTBOX Then Exit Function
Dim x As Long
x = SendMessageByString(List.hWnd, LB_FINDSTRINGEXACT, 0&, Query)
ListBoxCheckDup = IIf(x > -1, True, False)
End Function
Public Sub ClearListBoxes(frmTarget As Form)
Dim I, j, ctrltarget
For I = 0 To (frmTarget.Controls.Count - 1)
Set ctrltarget = frmTarget.Controls(I)
If TypeOf ctrltarget Is LISTBOX Then
ctrltarget.Clear
End If
Next I
End Sub
Public Sub AddHScroll(List As LISTBOX)
Dim I As Integer, intGreatestLen As Integer, lngGreatestWidth As Long
'Find Longest Text in Listbox
For I = 0 To List.ListCount - 1
If Len(List.List(I)) > Len(List.List(intGreatestLen)) Then
intGreatestLen = I
End If
Next I
'Get Twips
lngGreatestWidth = List.Parent.TextWidth(List.List(intGreatestLen) + Space(1))
'Space(1) is used to prevent the last Ch
' aracter from being cut off
'Convert to Pixels
lngGreatestWidth = lngGreatestWidth \ Screen.TwipsPerPixelX
'Use api to add scrollbar
SendMessage List.hWnd, LB_SETHORIZONTALEXTENT, lngGreatestWidth, 0
End Sub
Sub SaveFormState(ByVal SourceForm As Form)
Dim a As Long ' general purpose
Dim B As Long
Dim C As Long
Dim filename As String ' where to save to
Dim FHandle As Long ' FileHandle
' error handling code
On Error GoTo fError
' we create a filename based on the formname
filename = App.Path + "\" + SourceForm.Name + ".set"
' Get a filehandle
FHandle = FreeFile()
' open the file
#If DebugMode = 1 Then
Debug.Print "--------------------------------------------------------->"
Debug.Print "Saving Form State:" + SourceForm.Name
Debug.Print "FileName=" + filename
#End If
Open filename For Output As FHandle
' loop through all controls
' first we save the type then the name
For a = 0 To SourceForm.Controls.Count - 1
#If DebugMode = 1 Then
Debug.Print "Saving control:" + SourceForm.Controls(a).Name
#End If
' if its textbox we save the .text property
If TypeOf SourceForm.Controls(a) Is TextBox Then
Print #FHandle, "TextBox"
Print #FHandle, SourceForm.Controls(a).Name
Print #FHandle, "StartText"
Print #FHandle, SourceForm.Controls(a).Text
Print #FHandle, "EndText"
' print a separator
Print #FHandle, "|<->|"
End If
' if its a checkbox we save the .value property
If TypeOf SourceForm.Controls(a) Is CheckBox Then
Print #FHandle, "CheckBox"
Print #FHandle, SourceForm.Controls(a).Name
Print #FHandle, Str(SourceForm.Controls(a).Value)
' print a separator
Print #FHandle, "|<->|"
End If
' if its a option button we save its value
If TypeOf SourceForm.Controls(a) Is OptionButton Then
Print #FHandle, "OptionButton"
Print #FHandle, SourceForm.Controls(a).Name
Print #FHandle, Str(SourceForm.Controls(a).Value)
' print a separator
Print #FHandle, "|<->|"
End If
' if its a listbox we save the .text and list contents
If TypeOf SourceForm.Controls(a) Is LISTBOX Then
Print #FHandle, "ListBox"
Print #FHandle, SourceForm.Controls(a).Name
Print #FHandle, SourceForm.Controls(a).Text
Print #FHandle, "StartList"
For B = 0 To SourceForm.Controls(a).ListCount - 1
Print #FHandle, SourceForm.Controls(a).List(B)
Next B
Print #FHandle, "EndList"
' save listindex
Print #FHandle, CStr(SourceForm.Controls(a).ListIndex)
' print a separator
Print #FHandle, "|<->|"
End If
' if its a combobox, save .text and list items
If TypeOf SourceForm.Controls(a) Is ComboBox Then
Print #FHandle, "ComboBox"
Print #FHandle, SourceForm.Controls(a).Name
Print #FHandle, SourceForm.Controls(a).Text
Print #FHandle, "StartList"
For B = 0 To SourceForm.Controls(a).ListCount - 1
Print #FHandle, SourceForm.Controls(a).List(B)
Next B
Print #FHandle, "EndList"
' print a separator
Print #FHandle, "|<->|"
End If
Next a
' close file
#If DebugMode = 1 Then
Debug.Print "Closing File."
Debug.Print "<----------------------------------------------------------"
#End If
Close #FHandle
' stop error handler
On Error GoTo 0
Exit Sub
fError: ' Simple error handler
C = MsgBox("Error in SaveFormState. " + Err.Description + ", Number=" + CStr(Err.Number), vbAbortRetryIgnore)
If C = vbIgnore Then Resume Next
If C = vbRetry Then Resume
' else abort
End Sub
'===========================================================================
' LoadFormState:
' Loads the state of controls from file
'
' Currently Supports: TextBox, CheckBox, OptionButton, Listbox, ComboBox
'=============================================================================
Sub LoadFormState(ByVal SourceForm As Form)
Dim a As Long ' general purpose
Dim B As Long
Dim C As Long
Dim txt As String ' general purpose
Dim fData As String ' used to hold File Data
' these are variables used for controls data
Dim cType As String ' Type of control
Dim Cname As String ' Name of control
Dim cNum As Integer ' number of control
' vars for the file
Dim filename As String ' where to save to
Dim FHandle As Long ' FileHandle
' error handling code
'On Error GoTo fError
' we create a filename based on the formname
filename = App.Path + "\" + SourceForm.Name + ".set"
' abort if file does not exist
If Dir(filename) = "" Then
#If DebugMode = 1 Then
Debug.Print "File Not found:" + filename
#End If
Exit Sub
End If
' Get a filehandle
FHandle = FreeFile()
' open the file
#If DebugMode = 1 Then
Debug.Print "------------------------------------------------------>"
Debug.Print "Loading FormState:" + SourceForm.Name
Debug.Print "FileName:" + filename
#End If
Open filename For Input As FHandle
' go through file
While Not EOF(FHandle)
Line Input #FHandle, cType
Line Input #FHandle, Cname
' Get control number
cNum = -1
For a = 0 To SourceForm.Controls.Count - 1
If SourceForm.Controls(a).Name = Cname Then cNum = a
Next a
' add some debug info if in debugmode
#If DebugMode = 1 Then
Debug.Print "Control Type=" + cType
Debug.Print "Control Name=" + Cname
Debug.Print "Control Number=" + CStr(cNum)
#End If
' if we find control
If Not cNum = -1 Then
' Depending on type of control, what data we get
Select Case cType
Case "TextBox"
Line Input #FHandle, fData
fData = "": txt = ""
While Not fData = "EndText"
If Not txt = "" Then txt = txt + vbCrLf
txt = txt + fData
Line Input #FHandle, fData
Wend
' update control
SourceForm.Controls(cNum).Text = txt
Case "CheckBox"
' we get the value
Line Input #FHandle, fData
' update control
SourceForm.Controls(cNum).Value = fData
Case "OptionButton"
' we get the value
Line Input #FHandle, fData
' update control
SourceForm.Controls(cNum).Value = fData
Case "ListBox"
' clear listbox
SourceForm.Controls(cNum).Clear
' get .text property
Line Input #FHandle, fData
SourceForm.Controls(cNum).Text = fData
' read past /startlist
Line Input #FHandle, fData
fData = "": txt = ""
' Get List
While Not fData = "EndList"
If Not fData = "" Then SourceForm.Controls(cNum).AddItem fData
Line Input #FHandle, fData
Wend
' get listindex
Line Input #FHandle, fData
SourceForm.Controls(cNum).ListIndex = Val(fData)
Case "ComboBox"
' Clear combobox
SourceForm.Controls(cNum).Clear
' Get Text
Line Input #FHandle, fData
SourceForm.Controls(cNum).Text = fData
' readpast /startlist
Line Input #FHandle, fData
fData = "": txt = ""
' get list
While Not fData = "EndList"
If Not fData = "" Then SourceForm.Controls(cNum).AddItem fData
Line Input #FHandle, fData
Wend
End Select ' what type of control
End If ' if we found control
' read till seperator
fData = ""
While Not fData = "|<->|"
Line Input #FHandle, fData
Wend
Wend ' not end of File (EOF)
' close file
#If DebugMode = 1 Then
Debug.Print "Closing file.."
Debug.Print "<------------------------------------------------------"
#End If
Close #FHandle
Exit Sub
fError: ' Simple error handler
C = MsgBox("Error in LoadFormState. " + Err.Description + ", Number=" + CStr(Err.Number), vbAbortRetryIgnore)
If C = vbIgnore Then Resume Next
If C = vbRetry Then Resume
' else abort
End Sub
Sub add1(LISTBOX As LISTBOX)
LISTBOX.AddItem "test"
LISTBOX.AddItem "test2"
LISTBOX.AddItem "test3"
LISTBOX.AddItem "test4"
LISTBOX.AddItem "test5"
LISTBOX.AddItem "test6"
End Sub
Sub add2(LISTBOX As LISTBOX, txt As String)
LISTBOX.AddItem txt$
LISTBOX.AddItem txt$
LISTBOX.AddItem txt$
End Sub
Public Sub FancyLoadList(Dialog As CommonDialog, List As LISTBOX)
On Error GoTo e
Dialog.DialogTitle = "Please Load A List"
Dialog.CancelError = True
Dialog.ShowOpen
Loadlistbox Dialog.filename, List
e:
End Sub
Public Sub FancySaveList(Dialog As CommonDialog, List As LISTBOX)
Dialog.DialogTitle = "Please Save Your List."
Dialog.ShowSave
SaveListBox Dialog.filename, List
End Sub
This was originally not indented very well.
Reply With Quote
