Private Enum Constants
Const1
Const2
Const3
End Enum
#If False Then
Dim Const1, Const2, Const3
#End IfAttribute VB_Name = "modLockEnumCase"
Option Explicit
'modLockEnumCase.bas usage:
'1. Add to project.
'2. Select entire Enum block.
'3. Copy to Clipboard.
'4. Run LockEnumCase() from the Immediate Window. Optionally *suggest* length of each line.
'5. Paste after the Enum block.
'6. Remove from project when no longer needed.
Public Sub LockEnumCase(Optional ByVal LineLen As Integer = 80) 'Adjust length of output lines as desired
Attribute LockEnumCase.VB_Description = "Enforces the case of Enumerations via Conditional Compiler Directives."
Dim sBlock As String, sLine As String, sText As String, oMatch As Object 'Match
'See if there's anything to process; quit if no text was copied
If Clipboard.GetFormat(vbCFText) Then sText = Clipboard.GetText Else Exit Sub
'Prepend the conditional compiler directive that is set to False
sBlock = "#If False Then" & vbNewLine
'Dimension variables that reuses the Enum members' names
sLine = "Dim "
With CreateObject("VBScript.RegExp") 'New RegExp
.Global = True
.MultiLine = True
'Strip all comments
.Pattern = " +'.*$"
sText = .Replace(sText, vbNullString)
'Exclude Enum statements
.Pattern = "(\b(Private|Public)? Enum [A-Za-z]\w*\b)|(\bEnd Enum\b)"
sText = .Replace(sText, vbNullString)
'Split multiple expressions in a single line into their own lines
If InStrB(sText, ":") Then sText = Replace(sText, ":", vbNewLine)
'This should match most Enum member names, including those enclosed with []
.Pattern = "^ *([A-Za-z]\w*|\[.+\]) *(?:=|$)"
For Each oMatch In .Execute(sText)
sLine = sLine & (oMatch.SubMatches(0&) & ", ")
'Check if the string being built is exceeding
'the *suggested* limit of each output line
If Len(sLine) >= LineLen Then
'If so, commit this line to the output string
sBlock = sBlock & (sLine & "_")
'Begin anew at the next line
sLine = vbNewLine
End If
Next
End With
'Finish the conditional compiler directive block, removing empty lines as needed
sBlock = sBlock & (IIf(sLine <> vbNewLine, sLine, vbNullString) _
& vbNewLine & "#End If" & vbNewLine)
'Overwrite the last comma with a space
Mid$(sBlock, InStrRev(sBlock, ",")) = " "
'Try to erase the last underscore on the last line, if present
On Error Resume Next
Mid$(sBlock, InStrRev(sBlock, "_" & vbNewLine & "#")) = " "
On Error GoTo 0
'Copy back to the Clipboard
Clipboard.Clear
Clipboard.SetText sBlock
End Sub
Option Explicit
'Module: mOpenWith
'Version: 0.1
'Author: fafalone
'Purpose: Vista and above provides an API call for the Open With dialog, which offers more options
' than the previous typical method of using rundll
Public Declare Function SHOpenWithDialog Lib "shell32" (ByVal hWnd As Long, poainfo As OPENASINFO) As Long
Public Enum OPEN_AS_INFO_FLAGS
OAIF_ALLOW_REGISTRATION = 1 'Enable the "always use this program" checkbox. If not passed, it will be disabled.
OAIF_REGISTER_EXT = 2 'Do the registration after the user hits the OK button.
OAIF_EXEC = 4 'Execute file after registering.
OAIF_FORCE_REGISTRATION = 8 'Force the Always use this program checkbox to be checked. Typically, you won't use the OAIF_ALLOW_REGISTRATION flag when you pass this value.
OAIF_HIDE_REGISTRATION = 20 'Introduced in Windows Vista. Hide the Always use this program checkbox. If this flag is specified, the OAIF_ALLOW_REGISTRATION and OAIF_FORCE_REGISTRATION flags will be ignored.
OAIF_URL_PROTOCOL = 40 'Introduced in Windows Vista. The value for the extension that is passed is actually a protocol, so the Open With dialog box should show applications that are registered as capable of handling that protocol.
OAIF_FILE_IS_URI = 80 'Introduced in Windows 8. The location pointed to by the pcszFile parameter is given as a URI.
End Enum
Public Type OPENASINFO
pcszFile As Long
pcszClass As Long 'file type description for registering the type with 'always open', if not set uses extension, as in 'XYZ File'
oafInFlags As OPEN_AS_INFO_FLAGS
End Type
Public Function OpenWith(sFile As String, lFlags As OPEN_AS_INFO_FLAGS, Optional hWndParent As Long, Optional sClass As String) As Long
Dim oai As OPENASINFO
oai.pcszFile = StrPtr(sFile)
oai.oafInFlags = lFlags
If sClass <> "" Then oai.pcszClass = StrPtr(sClass)
OpenWith = SHOpenWithDialog(hWndParent, oai)
End Function
Option Explicit
'
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
'
Private Const Utf8CodePage As Long = 65001
'
Public Enum AsciiUnicodeEncoding
AsciiEncode = 0
Utf8Encode = 1
Utf16Encode = 2
End Enum
'
Public Function ReadAsciiOrUnicodeNotepadFile(sFileSpec As String) As String
' These are typically .TXT files. They can be read with notepad.
Dim iFle As Long
Dim bb() As Byte
Dim i As Integer
Dim s As String
'
iFle = FreeFile
Open sFileSpec For Binary As iFle
If LOF(iFle) = 0 Then
Close iFle
Exit Function
End If
'
Get iFle, , i
Select Case i
Case &HFEFF ' UTF16 file header. First byte = FF, second byte = FE.
ReDim bb(1 To LOF(iFle) - 2&)
Get iFle, , bb
ReadAsciiOrUnicodeNotepadFile = bb ' This directly copies the byte array to the Unicode string (no conversion).
Case &HBBEF
ReDim bb(1 To LOF(iFle) - 3&)
Seek iFle, 4
Get iFle, , bb
ReadAsciiOrUnicodeNotepadFile = Utf8toUtf16(bb)
Case Else ' Assume ascii.
s = Space$(LOF(iFle))
Seek iFle, 1
Get iFle, , s
ReadAsciiOrUnicodeNotepadFile = s
End Select
'
Close iFle
End Function
Public Sub WriteAsciiOrUnicodeNotepadFile(sFileSpec As String, sData As String, Encoding As AsciiUnicodeEncoding)
' These are typically .TXT files. They can be read with notepad.
Dim iFle As Long
'
iFle = FreeFile
Open sFileSpec For Binary As iFle
Select Case Encoding
Case AsciiEncode
Put iFle, , sData
Case Utf8Encode
Put iFle, , CByte(&HEF)
Put iFle, , CByte(&HBB)
Put iFle, , CByte(&HBF)
Put iFle, , Utf16toUtf8(sData)
Case Utf16Encode
Put iFle, , &HFEFF ' This is the Unicode header to a text file. First byte = FF, second byte = FE.
Put iFle, , Utf16ByteArrayFromString(sData)
End Select
Close iFle
End Sub
Public Function Utf16ByteArrayFromString(s As String) As Byte()
' This directly copies the Unicode string into the byte array, using two bytes per character (i.e., Unicode).
Utf16ByteArrayFromString = s
End Function
Public Function Utf16toUtf8(s As String) As Byte()
' UTF-8 returned to VB6 as a byte array (zero based) because it's pretty useless to VB6 as anything else.
Dim iLen As Long
Dim bbBuf() As Byte
'
iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), 0, 0, 0, 0)
ReDim bbBuf(0 To iLen - 1) ' Will be initialized as all &h00.
iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), VarPtr(bbBuf(0)), iLen, 0, 0)
Utf16toUtf8 = bbBuf
End Function
Public Function Utf8toUtf16(bb() As Byte) As String
' Incoming must be a dimensioned byte array with a UTF-8 string in it.
Dim sBuf As String
Dim iLen As Long
'
iLen = MultiByteToWideChar(Utf8CodePage, 0, VarPtr(bb(LBound(bb))), UBound(bb) - LBound(bb) + 1, 0, 0)
sBuf = String$(iLen, 0)
iLen = MultiByteToWideChar(Utf8CodePage, 0, VarPtr(bb(LBound(bb))), UBound(bb) - LBound(bb) + 1, StrPtr(sBuf), Len(sBuf))
Utf8toUtf16 = sBuf
End FunctionDim conCollection As Collection
Dim init As Boolean
Sub PushOne(conname As String, v As Variant)
On Error Resume Next
conCollection.Add v, conname
Set v = conCollection(conname)
End Sub
Sub CloseAllConnections()
Dim v As Variant, BB As Boolean
On Error Resume Next
If Not init Then Exit Sub
If conCollection.Count > 0 Then
Dim i As Long
Err.clear
For i = conCollection.Count To 1 Step -1
On Error Resume Next
BB = conCollection(i).connectionstring <> ""
If Err.Number = 0 Then
If conCollection(i).ActiveConnection <> "" Then conCollection(i).Close
End If
conCollection.Remove i
Err.clear
Next i
Set conCollection = New Collection
End If
Err.clear
End Sub
Function getone(conname As String, this As Variant) As Boolean
On Error Resume Next
Dim v As Variant
InitMe
Err.clear
Set v = conCollection(conname)
If Err.Number = 0 Then getone = True: Set this = v
Err.clear
End Function
Sub InitMe()
If init Then Exit Sub
Set conCollection = New Collection
init = True
End Sub
hBtn = Command1.hWnd
Call SendMessage(Command1.hWnd, BM_SETIMAGE, 1&, ByVal hIcon1)
SetButtonStyle Command1.hWnd, BS_NOTIFY Or BS_LEFTPrivate Sub Command1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If bFlag Then
ToggleButtonState Command1.hWnd, 0
bFlag = False
Else
ToggleButtonState Command1.hWnd, 1
bFlag = True
End If
End Sub
Public Sub ToggleButtonState(hWnd As Long, lState As Long)
Call SendMessage(hWnd, BM_SETSTATE, lState, ByVal 0&)
End SubPublic Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'[...other subclass code]
Case WM_COMMAND
Dim lCode As Long
lCode = HiWord(wParam)
Select Case lCode
Case BN_KILLFOCUS
If lParam = hBtn Then
If bFlag Then
Call SendMessage(hBtn, BM_SETSTATE, 1&, ByVal 0&)
End If
End If
WndProc = 1
Exit Function
'[...other subclass codePublic Const BM_SETIMAGE = &HF7
Public Const BM_SETSTATE = &HF3
Public Const BS_LEFT = &H100&
Public Const BS_NOTIFY = &H4000&
Public Const BN_KILLFOCUS = 7&
Public Const WM_COMMAND = &H111
Public Const GWL_STYLE = (-16)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Function SetButtonStyle(hWnd As Long, dwNewStyle As Long, Optional bAdd As Boolean = True) As Long
Dim dwStyle As Long
If bAdd Then
dwStyle = GetWindowLong(hWnd, GWL_STYLE)
End If
dwStyle = dwStyle Or dwNewStyle
SetButtonStyle = SetWindowLong(hWnd, GWL_STYLE, dwStyle)
End Function
Public Function HiWord(dwValue As Long) As Integer
CopyMemory HiWord, ByVal VarPtr(dwValue) + 2, 2
End Function