CodeKeep VB6 Feed

Alternating Table Row Colors in SSRS

Tue, 12 Jun 2012 22:54:46 GMT

Description: Alternating Table Row Colors in SSRS

Link: http://www.codekeep.net/snippets/50af7412-f2fd-4080-84b7-ca3e3c49ee38.aspx

= IIf(RowNumber(Nothing) Mod 2 = 0, "Silver", "Transparent")

Nz in VB 6 etc.

Mon, 02 Aug 2010 14:15:55 GMT

Description: VBA has a function Nz that checks for null, VB6 etc. does not

Link: http://www.codekeep.net/snippets/6fee24fa-56b7-49a0-99ed-aee19233bbbe.aspx

Function Nz(ByVal V As Variant, Optional ByVal ValueIfNull As Variant) As Variant
	If Not IsNull(V) Then
		Nz = V
	Else
		If IsMissing(ValueIfNull) Then
			If VarType(V) = vbString Then
				Nz = ""
			Else
				Nz = 0
			End If
		Else
			V = ValueIfNull
		End If
	End If
End Function

Extended color enumeration for VB

Mon, 07 Jun 2010 12:26:02 GMT

Description: Extended color enumeration for VB

Link: http://www.codekeep.net/snippets/2e25cebc-d194-4ce6-ade2-5b774a064c05.aspx

Public Enum ExtendedColorTypes
    'vbWhite = &HFFFFFF
    vbLightGray = &HE0E0E0
    vbGray = &HC0C0C0
    vbMediumGray = &H808080
    vbDarkGray = &H404040
    'vbBlack = &H0
    vbPaleRed = &HC0C0FF
    vbLightRed = &H8080FF
    'vbRed = &HFF
    vbMediumRed = &HC0&
    vbDarkRed = &H80&
    vbBlackRed = &H40&
    vbPaleOrange = &HC0E0FF
    vbLightOrange = &H80C0FF
    vbOrange = &H80FF&
    vbMediumOrange = &H40C0&
    vbDarkOrange = &H4080&
    vbBlackOrange = &H404080
    vbPaleYellow = &HC0FFFF
    vbLightYellow = &H80FFFF
    'vbYellow = &HFFFF
    vbMediumYellow = &HC0C0&
    vbDarkYellow = &H8080&
    vbBlackYellow = &H4040&
    vbPaleGreen = &HC0FFC0
    vbLightGreen = &H80FF80
    'vbGreen = &HFF00
    vbMediumGreen = &HC000&
    vbDarkGreen = &H8000&
    vbBlackGreen = &H4000&
    vbPaleCyan = &HFFFFC0
    vbLightCyan = &HFFFF80
    'vbCyan = &HFFFF00
    vbMediumCyan = &HC0C000
    vbDarkCyan = &H808000
    vbBlackCyan = &H404000
    vbPaleBlue = &HFFC0C0
    vbLightBlue = &HFF8080
    'vbBlue = &HFF0000
    vbMediumBlue = &HC00000
    vbDarkBlue = &H800000
    vbBlackBlue = &H400000
    vbPalePurple = &HFFC0FF
    vbLightPurple = &HFF80FF
    vbPurple = &HFF00FF
    'vbMagenta = &HFF00FF
    vbMediumPurple = &HC000C0
    vbDarkPurple = &H800080
    vbBlackPurple = &H400040
End Enum

Print errors from failed db connect

Wed, 05 Sep 2007 19:34:34 GMT

Description: Print errors from failed db connect

Link: http://www.codekeep.net/snippets/1497bfb4-73c6-4e19-a55c-b3f1468a3840.aspx

if aCnx.Errors.Count <> 0 Then
For each errItem in aCnx.Errors
         If errItem.Number <> 0 Then
            Response.Write "<br>NativeError = " & errItem.NativeError
            Response.Write "<br>Description = " & errItem.Description
            Response.Write "<br>SQLState    = " & errItem.SQLState
            Response.Write "<br>Source      = " & errItem.Source
         End If
      Next
  Response.End
End If

Determine if running from EXE or IDE

Thu, 17 May 2007 16:16:27 GMT

Description: Determines if the program is executing as a compiled EXE or in debug mode from within the VB6 IDE.

Link: http://www.codekeep.net/snippets/3d176440-20b7-4624-830b-a00bc2efdfec.aspx

Public Function RunningFromIDE() As Boolean
    On Error GoTo ErrHandler
    'Because debug statements are ignored when the app is compiled, the next statment will never be executed in the EXE.
    Debug.Print 1 / 0
    RunningFromIDE = False
    Exit Function
ErrHandler:
    'If we get an error then we are running in IDE / Debug mode
    RunningFromIDE = True
End Function

List DB's on an sql

Thu, 26 Oct 2006 08:17:41 GMT

Description: List db's

Link: http://www.codekeep.net/snippets/e37f3144-bf25-4400-85f1-2c4e017761c0.aspx

Private Sub GetDatabase(strServer As String)

    Dim strDatabase As String
    Dim strPassword As String
    Dim i As Integer
    Dim oSQLServer As SQLDMO.SQLServer
    
    On Error Resume Next
    Set oSQLServer = New SQLDMO.SQLServer
    With oSQLServer
	'
	' You may or may not need this bit
	'
    '.LoginSecure = True 
    .Connect strServer, "username", "password"
    
    For i = 1 To .Databases.Count

          strDatabase = .Databases(i).Name
            Me.Combo1.AddItem strDatabase
    Next

   oSQLServer.Close
End With
   Set oSQLServer = Nothing

End Sub

List SQL Server

Thu, 26 Oct 2006 08:02:20 GMT

Description: List all the available SQL servers

Link: http://www.codekeep.net/snippets/35e55a49-0a55-4736-bd7b-b459a09f36c0.aspx

Dim oSQLServer As SQLDMO.SQLServer
    Dim lngIndex As Long
    Dim nlServers As SQLDMO.NameList
    Dim strHostName As String
    Dim lngFoundComma As Long
On Error Resume Next
    
    Set oSQLServer = New SQLDMO.SQLServer
    cmbServer.Clear
    cmbServer.Text = "Select a Server"
    Set nlServers = oSQLServer.Application.ListAvailableSQLServers
    
    For lngIndex = 1 To nlServers.Count
strHostName = nlServers.Item(lngIndex)
        If strHostName Like "*.*.*.*" Then
            lngFoundComma = InStr(strHostName, ",")
            If lngFoundComma > 0 Then
                strHostName = Left$(strHostName, lngFoundComma - 1)
            End If
        End If
        cmbServer.AddItem strHostName
    Next
oSQLServer.Close
    Set oSQLServer = Nothing

FileReadToAarry_fbas

Thu, 12 Jan 2006 08:13:06 GMT

Description: Liest eine Text Datei in ein Arry

Link: http://www.codekeep.net/snippets/493450bf-49f1-43fe-ae98-9241d699eeb6.aspx

 Function FileReadToAarry_fbas(ByVal lstrDirNameExt As String, _
                                   varArryVar() As Variant, _
                         Optional fLbolIgnorRemarkt As Boolean = False) As Long
  ' Comments   : Liest eine Text Datei in ein Arry
    
  
  Dim lngLlngNLines As Long
  lngLlngNLines = 0
  
  If FileFindBol_fbas(lstrDirNameExt) Then
     Dim fs As New Scripting.FileSystemObject
     Dim ts As Scripting.TextStream
     Set ts = fs.OpenTextFile(lstrDirNameExt, ForReading)
   
     Dim lstrInputBuff As String
     Dim fLbolAddLineToArry As Boolean
     Do While ts.AtEndOfStream <> True  ' Schleife bis Dateiende.
       lstrInputBuff = ts.ReadLine
       fLbolAddLineToArry = True
      
       If fLbolIgnorRemarkt Then
          fLbolAddLineToArry = (False = fbasIsStrRemarkt(lstrInputBuff))
       End If
       
       If fLbolAddLineToArry Then
         lngLlngNLines = lngLlngNLines + 1
         ReDim Preserve varArryVar(lngLlngNLines - 1)
         varArryVar(lngLlngNLines - 1) = lstrInputBuff
       End If
     Loop
     ts.Close
     Set ts = Nothing
     Set fs = Nothing
  Else
     lngLlngNLines = -1
  End If
  
  
ExitFun:
  FileReadToAarry_fbas = lngLlngNLines
  Exit Function
  
ExitErr:
  FileReadToAarry_fbas = lngLlngNLines
  Resume ExitFun:
End Function

Create excel spreadsheet VB6

Fri, 16 Dec 2005 06:02:26 GMT

Description: This code dynamically creates an excel spreadsheet, some simple formatting and populates.

Link: http://www.codekeep.net/snippets/1047d469-6fe6-486c-8e3c-d6a931c36406.aspx

'Must add reference to "Microsoft Excel 10.0 Object Library"

Dim xlObj As Object, xlBook As Excel.Workbook, xlWs As Excel.Worksheet
Dim i as Integer

Set xlObj = CreateObject("Excel.Application")
Set xlBook = xlObj.Workbooks.Add
Set xlWs = xlBook.Worksheets("sheet1")

xlWs.Rows(1).RowHeight = 20  'Make Header row taller
xlWs.Range(xlWs.Cells(1, 1), xlWs.Cells(1, 4)).Merge
xlWs.Range(xlWs.Cells(1, 5), xlWs.Cells(1, 10)).Merge
    
xlWs.Cells(1, 1).HorizontalAlignment = Excel.xlCenter
xlWs.Cells(1, 1).Font.Size = 13
xlWs.Cells(1, 1).Font.Bold = True
xlWs.Cells(1, 1).Value = "Header Row 1"
   
xlWs.Cells(1, 5).HorizontalAlignment = Excel.xlCenter
xlWs.Cells(1, 5).Font.Size = 13
xlWs.Cells(1, 5).Font.Bold = True
xlWs.Cells(1, 5).Value = "Header Row 2"

For i = 3 to 50'populate rows
     xlWs.Cells(i, 1).Value = "Row 1 Data " & i
     xlWs.Cells(i, 5).Value = "Row 2 Data " & i
Next i

xlWs.Columns("A:ZZ").AutoFit
xlWs.Columns("A:ZZ").Font.Size = 8
xlObj.Visible = True 'Show Report

'Clean up Excel resources
Set xlObj = Nothing
Set xlBook = Nothing
Set xlWs = Nothing

PCUser Function

Thu, 08 Dec 2005 20:16:03 GMT

Description: VB6 function for getting the Windows user name

Link: http://www.codekeep.net/snippets/84ab5fcb-80d7-4be5-9032-41f2b3efe6a7.aspx

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'''''

Public Function PCUser() As String
    Dim lNameLength As Long
    Dim lResult As String
    Static sPCUser As String
    If sPCUser = "" Then
        sPCUser = String(200, 32)
        lNameLength = 200
        lResult = GetUserName(sPCUser, lNameLength)
        sPCUser = Left(Trim(sPCUser), Len(Trim(sPCUser)) - 1)
    End If
    PCUser = sPCUser
End Function

PCName Function

Thu, 08 Dec 2005 20:14:50 GMT

Description: VB6 function for returning the PC's name

Link: http://www.codekeep.net/snippets/9e3816f4-d99d-46e0-a025-2049606404c4.aspx

Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
''''

Public Function PCName() As String
    Static sPCName As String
    Dim lNameLength As Long
    Dim lResult As String
    If sPCName = "" Then
        sPCName = String(50, 32)
        lNameLength = 50
        lResult = GetComputerName(sPCName, lNameLength)
        sPCName = Left(Trim(sPCName), Len(Trim(sPCName)) - 1)
    End If
    PCName = sPCName
End Function

VB6 Pause Function

Thu, 08 Dec 2005 20:13:28 GMT

Description: VB6 Pause Function

Link: http://www.codekeep.net/snippets/cba3985d-33d1-46d9-ae80-1a104991b07a.aspx

Public Sub Pause(ByVal Seconds As Long)
    Dim vStart As Variant
    vStart = Timer
    Do While Timer < vStart + Seconds
        If Timer - vStart < 0 Then
            Exit Sub
        End If
        DoEvents
    Loop
End Sub

modExcel

Thu, 08 Dec 2005 20:11:34 GMT

Description: Module for exporting ADO Recordsets to Excel

Link: http://www.codekeep.net/snippets/3e217dff-4b11-48c2-994c-e67fdcb9b623.aspx

Option Explicit
Option Compare Text

Private Type ExlCell
    row As Long
    col As Long
End Type

Private Function GetExportToSheet(oExcel As Variant, Optional ByVal strToSheetName As String = "Export", Optional ByVal strToBookName As String = "Export") As Variant

    'Purpose:
    '       To return the Export To Worksheet
    '
    '   Input Parameters:
    '       oExcel           -
    '       strToBookName   -   Name of Excel Book to export to
    '
    '   Return Value:
    '       Newly created worksheet
    
    Dim oExportBook As Object
    Dim oToSheet As Variant
    Dim oBook As Variant
    
    On Error GoTo ErrorHandler
    
    'Find Export Book
    On Error Resume Next
    For Each oBook In oExcel.Workbooks
        Err.Clear
        If oBook.BuiltinDocumentProperties("Title") = strToBookName Then
            If Err.Number = 0 Then
                Set oExportBook = oBook
                Exit For
            End If
        End If
    Next
    Set oBook = Nothing
    
    On Error GoTo ErrorHandler
    
    'Create New Book/Get To Sheet
    If oExportBook Is Nothing Then
        Set oExportBook = oExcel.Workbooks.Add
        oExportBook.BuiltinDocumentProperties("Title") = strToBookName
        Set oToSheet = oExportBook.Sheets(1)
    Else
        Set oToSheet = oExportBook.Sheets.Add
    End If
    
    'Name To Sheet
    oToSheet.Name = strToSheetName & "(" & oExportBook.Sheets.Count & ")"
    
    'Return worksheet
ExitCode:
    Set GetExportToSheet = oToSheet
    Exit Function
    
ErrorHandler:
    'ErrorProc MOD_NAME & ".GetExportToSheet", Err.Number, Err.Description
    MsgBox "Error ocurred: " & Err.Number & " - " & Err.Description
    Resume ExitCode
    
End Function

Public Sub ToExcel(ByVal rs As ADODB.Recordset, Optional ByVal strCaption As String = "Export")
    
    Dim oExcel As Object
    Dim oSheet As Object ' OLE automation object
    Dim oField As ADODB.Field
    Dim strPasteData As String
    Dim strLastColumn As String
    Dim vntCursor As Variant
    
    'Get Excel
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")
    ' If Excel is not launched start it
    If Err.Number = 429 Then
        Err.Clear
        Set oExcel = CreateObject("Excel.Application")
        If Err.Number = 429 Then
            MsgBox Err.Source & " " & Err.Number & " - " & Err.Description, vbExclamation + vbOKOnly
            Exit Sub
        End If

    End If
    
    'Get Sheet to Export To
    Set oSheet = GetExportToSheet(oExcel, strCaption)
    
    'Get Heading Row
    strPasteData = ""
    For Each oField In rs.Fields
        strPasteData = strPasteData & vbTab & oField.Name
    Next
    Set oField = Nothing
    
    'Get Data
    vntCursor = rs.Bookmark
    rs.MoveFirst
    strPasteData = strPasteData & vbCr & Replace(rs.GetString, vbCrLf, "  ")
    
    'Reset cursor
     rs.Bookmark = vntCursor
    
    'Paste Data
    ClearClipboard
    oSheet.Range("A1").Activate
    Clipboard.SetText Mid$(strPasteData, 2) 'Skip tab
    oSheet.Paste
    ClearClipboard
    
    'Format Sheet
    strLastColumn = Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZ", rs.Fields.Count, 1)
    oSheet.Range("A1:" & strLastColumn & "1").Font.Bold = True
    oSheet.Columns("A:" & strLastColumn).AutoFit
    
    'Show Excel
    oExcel.Visible = True
    If oExcel.WindowState = vbMinimized Then
        oExcel.WindowState = vbNormal
    Else
        oExcel.WindowState = oExcel.WindowState
    End If
    oExcel.Visible = True
    oExcel.Interactive = True
    
    ' Clean up:
    Set oSheet = Nothing ' Remove object variable.
    Set oExcel = Nothing ' Remove object variable.
        
End Sub

ValidRS

Thu, 08 Dec 2005 20:08:28 GMT

Description: Function for determining if a recordset is valid (contains records).

Link: http://www.codekeep.net/snippets/a4012785-9ad0-4566-a768-97b7cfe6deb1.aspx

Public Function ValidRS(oRS As Recordset) As Boolean
    If oRS Is Nothing Then
        ValidRS = False
    ElseIf oRS.State <> adStateOpen Then
        ValidRS = False
    ElseIf oRS.BOF And oRS.EOF Then
        ValidRS = False
    ElseIf oRS.RecordCount = 0 Then
        ValidRS = False
    Else
        ValidRS = True
    End If
End Function

DebugRS

Thu, 08 Dec 2005 20:06:56 GMT

Description: Dumps a recordset for debugging

Link: http://www.codekeep.net/snippets/3d8b6071-7fa1-4887-9700-463a83dd928a.aspx

Public Sub DebugRS(ByVal rs As ADODB.Recordset, Optional RowsToPrint As Long, Optional LogFile As String)
    Dim i As Long, j As Long
    Dim fso As Object
    Dim file As Object
    Const ioModeForWriting As Integer = 1
    Const ioModeForAppending As Integer = 8
    
    Dim oRS As ADODB.Recordset
    Set oRS = rs.Clone
    oRS.Filter = rs.Filter

    If LogFile <> "" Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set file = fso.OpenTextFile(LogFile, ioModeForAppending, True)
        file.WriteBlankLines 2
        file.WriteLine String(25, "*") & "  " & Format(Now, "dd-mmm-yyyy hh:mm:ss AM/PM") & "  " & String(25, "*")
        file.WriteLine ">>>>>>>>  Source   <<<<<<<<"
        file.Write oRS.Source
        file.WriteBlankLines 1
        file.WriteLine ">>>>>>>>  Filter: " & oRS.Filter
    End If

    If ValidRS(oRS) Then
        Do While Not oRS.EOF
            j = j + 1
            If file Is Nothing Then
                Debug.Print ""
                Debug.Print "====== Record " & CStr(oRS.Bookmark) & " ========================================"
            Else
                file.WriteBlankLines 1
                file.WriteLine "====== Record " & CStr(oRS.Bookmark) & " ========================================"
            End If
            For i = 0 To oRS.Fields.Count - 1
                If file Is Nothing Then
                    Debug.Print "(" & CStr(i) & ") " & oRS.Fields(i).Name & " = " & CStr(oRS.Fields(i).Value & "")
                Else
                    file.WriteLine "(" & CStr(i) & ") " & oRS.Fields(i).Name & " = " & CStr(oRS.Fields(i).Value & "")
                End If
                DoEvents
            Next
            oRS.MoveNext
            DoEvents
            If j = RowsToPrint Then
                Exit Do
            End If
        Loop
    End If

    If Not file Is Nothing Then
        file.WriteBlankLines 1
        file.WriteLine ">>>>>> EOF <<<<<<  RecordCount = " & oRS.RecordCount & "  >>>>>>"
        file.Close
        Set file = Nothing
        Set fso = Nothing
        Debug.Print "done."
    End If
    Set oRS = Nothing
End Sub

VB6 modAspectRatio

Thu, 08 Dec 2005 13:46:36 GMT

Description: Module for maintaining a form's aspect ratio

Link: http://www.codekeep.net/snippets/0905b038-ffc3-479a-9e22-62ad969ac418.aspx

Option Explicit

' ***********************************************************
' Subclassing.
'   Maintaining Form Aspect Ratio During Resize
'   http://www.vb-helper.com/howto_keep_form_aspect_ratio.html
' ***********************************************************

Public OldWindowProc As Long
Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As WINDOWPOS) As Long
Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)

Type WINDOWPOS
    hWnd As Long
    hWndInsertAfter As Long
    x As Long
    Y As Long
    cx As Long
    cy As Long
    FLAGS As Long
End Type
Public Const WM_WINDOWPOSCHANGING = &H46
Public Const WM_WINDOWPOSCHANGED = &H47

' Process messages.
Public Function NewWindowProc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As WINDOWPOS) As Long
Static done_before As Boolean
Static aspect As Single
Dim new_aspect As Single

    ' Keep the aspect ratio.
    If msg = WM_WINDOWPOSCHANGING Then
        If lParam.cy > 0 Then
            ' Save the aspect ratio the first.
            If Not done_before Then
                aspect = lParam.cx / lParam.cy
                done_before = True
            End If
            
            new_aspect = lParam.cx / lParam.cy
            If new_aspect > aspect Then
                ' Too short/wide. Make it taller.
                lParam.cy = lParam.cx / aspect
            Else
                ' Too tall/thin. Make it wider.
                lParam.cx = aspect * lParam.cy
            End If
        End If
    End If

    ' Continue normal processing. VERY IMPORTANT!
    NewWindowProc = CallWindowProc(OldWindowProc, hWnd, msg, wParam, lParam)
End Function

VB6 modScreenAPI

Thu, 08 Dec 2005 13:45:23 GMT

Description: Module of Common Routines for Screen Captures

Link: http://www.codekeep.net/snippets/2f754cc0-2e09-47d9-b7ef-204e9332de50.aspx

Option Explicit
Option Base 0
 '--------------------------------------------------------------------
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '
 ' Visual Basic 4.0 16/32 Capture Routines
 '
 ' This module contains several routines for capturing windows into a
 ' picture.  All the routines work on both 16 and 32 bit Windows
 ' platforms.
 ' The routines also have palette support.
 '
 ' CreateBitmapPicture - Creates a picture object from a bitmap and
 ' palette.
 ' CaptureWindow - Captures any window given a window handle.
 ' CaptureActiveWindow - Captures the active window on the desktop.
 ' CaptureForm - Captures the entire form.
 ' CaptureClient - Captures the client area of a form.
 ' CaptureScreen - Captures the entire screen.
 ' PrintPictureToFitPage - prints any picture as big as possible on
 ' the page.
 '
 ' NOTES
 '    - No error trapping is included in these routines.
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

 Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
 End Type

 Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
 End Type

 Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
 End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "USER32" () As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long

Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

 
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 '
 ' CreateBitmapPicture
 '    - Creates a bitmap type Picture object from a bitmap and palette.
 '
 ' hBmp
 '    - Handle to a bitmap.
 '
 ' hPal
 '    - Handle to a Palette.
 '    - Can be null if the bitmap doesn't use a palette.
 '
 ' Returns
 '    -

IsCompiledEXE

Thu, 01 Dec 2005 10:48:29 GMT

Description: Check if application is being run in VB6 or compiled EXE.

Link: http://www.codekeep.net/snippets/7f8af69f-afdb-4e4b-bc82-1969cdf66d9e.aspx

Private Function IsCompiledEXE() As Boolean
'===============================================================================
  On Error Resume Next
  Debug.Print 0 / 0
  If Err.Number = 0 Then IsCompiledEXE = True
End Function

Returns a files content

Mon, 12 Sep 2005 12:16:26 GMT

Description: Returns the contents of a file

Link: http://www.codekeep.net/snippets/48e3db65-1924-4762-8164-fab427cc373c.aspx

Public Function FileToString(ByVal sFileName As String) As String
Dim lFreeFile As Long
Dim sFileContents As String
  
On Error GoTo errRtn
   sFileContents = ""
   lFreeFile = FreeFile
   Open sFileName For Binary As #lFreeFile
   sFileContents = Input(LOF(lFreeFile), lFreeFile)
   Close lFreeFile
   FileToString = sFileContents
Exit Function
errRtn:
   Err.Clear
   FileToString = ""
End Function

Insert checkboxes to Excel grid

Tue, 23 Aug 2005 00:50:50 GMT

Description: Create checkbozes inside cells in excel

Link: http://www.codekeep.net/snippets/ea4bb68a-a0f7-43bf-a986-d64719dee753.aspx

Sub loadCBX()

    Dim myCell As Range
    Dim myCBX As CheckBox
    Dim rng As Range
        
    shtPivotConfig.CheckBoxes.Delete  'nice for testing!
    Set rng = shtPivotConfig.Range("config.CategorySorting")
    
    For Each myCell In rng
        With myCell
            .NumberFormat = ";;;"
            .Locked = False
            Set myCBX = shtPivotConfig.CheckBoxes.Add _
                    (Top:=.Top, Width:=.Width, _
                     Height:=.Height, Left:=.Left)
        End With
        With myCBX
            .Name = "cbx_" & myCell.Address(0, 0)
            .LinkedCell = myCell.Address(external:=True)
            .Caption = ""
            .Placement = xlMoveAndSize
            '.OnAction = ThisWorkbook.Name & "!dothework"
        End With
    Next myCell


End Sub