IMPORTANT!

Snipt is going open source. We've toyed with this idea for quite a while, and have finally decided it's the right way to move forward.

A few things:
  • The entire Snipt source code will be released on GitHub under the 3-clause BSD License on Friday, September 10th.
  • While we'd like to think we're perfect, we realize we're only human. By open sourcing the software that runs this website, certain bugs or security flaws may be discovered that could compromise the privacy of your snipts.
  • Only the Lion Burger team will be able to push commits to the Snipt.net site. Contributors should send a pull request to add new features or submit patches.
  • By using this site, you agree not to be too angry or take any legal action against Lion Burger should this whole thing go up in flames some day.
  • Follow us on Twitter for updates.
I agree, close this message
Sign up to create your own snipts, or login.

Latest 100 public snipts » beccoblu's snipts » vb6 The latest vb6 snipts from beccoblu.

showing 1-7 of 7 snipts for vb6
  • ∞ VB6: Always On Top forms 
    Private Declare Function SetWindowPos Lib "user32" _
  (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

Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

'--------------------

Public Sub SetAlwaysOnTop(hwnd As Long, AOT As Boolean)

  If AOT Then
    SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
  Else
    SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
  End If

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Feb 15, 2010 at 5:28 a.m. EST
  • ∞ VB6: Connect via ADO to Access 2007 database 
    'Needs Microsoft ActiveX Data Objects Library

ConnectionString = "PROVIDER=Microsoft.ACE.OLEDB.12.0;" & _
  "Data Source=" & FileName & ";"

    copy | embed

    0 comments - tagged in  posted by beccoblu on Feb 15, 2010 at 5:24 a.m. EST
  • ∞ VB6: Write a message in a daily log 
    Public Sub WriteLog(Message As String)

  Dim fso, fileName As String, logString As String, f as Integer
  
  fileName = App.path & "\Log_" & Format(Now, "yyyymmdd") & ".txt"
  logString = Format(Now, "hh:mm:ss") & " - " & Message
  f = Freefile
  Open fileName For Append As #f
  Print #f, logString
  Close #f

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Feb 14, 2010 at 10:04 a.m. EST
  • ∞ VB6: Darken background when opening a modal form 
    '##### frmGray.frm

Option Explicit

Private Const GWL_EXSTYLE As Long = (-20)
Private Const WS_EX_RIGHT As Long = &H1000
Private Const WS_EX_LEFTSCROLLBAR As Long = &H4000
Private Const WS_EX_LAYERED As Long = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const LWA_COLORKEY As Long = &H1
Private Const LWA_ALPHA As Long = &H2

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 Declare Function SetLayeredWindowAttributes Lib "User32" _
  (ByVal hwnd As Long, _
  ByVal crKey As Long, _
  ByVal bAlpha As Long, _
  ByVal dwFlags As Long) As Long
  
Dim formOpening As Boolean

'--------------------

Private Sub Form_Activate()
  
  If formOpening Then
    Me.WindowState = vbMaximized
    frmModalForm.Show vbModal
    Unload Me
    formOpening = False
  End If

End Sub

'--------------------

Private Sub Form_Load()

  formOpening = True
  Me.BackColor = vbBlack
  Call AlphaForm

End Sub

'--------------------

Private Function AlphaForm()

  Dim style As Long
  Dim alpha As Integer

  alpha = 120    'set alpha transparency (0-255)
  style = GetWindowLong(Me.hwnd, GWL_EXSTYLE)

  If Not (style And WS_EX_LAYERED = WS_EX_LAYERED) Then

    style = style Or WS_EX_LAYERED
    SetWindowLong Me.hwnd, GWL_EXSTYLE, style
    SetLayeredWindowAttributes Me.hwnd, 0&, alpha, LWA_ALPHA

  End If

End Function



'##### frmCaller.frm

Private Sub Command1_Click()

  frmGray.Show vbModal    'instead of frmModalForm.Show vbModal

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Feb 12, 2010 at 12:07 p.m. EST
  • ∞ VB6: Operations involving controls at startup time 
    Dim StartUp As Boolean

'--------------------

Private Sub Form_Load()

  StartUp = True

End Sub

'--------------------

Private Sub Form_Activate()

  If StartUp Then
    Text1.SetFocus    ' Or any other operation involving controls, to run only at startup
    StartUp = False
  End If

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Feb 10, 2010 at 11:34 a.m. EST
  • ∞ VB6: Move a form by dragging it with mouse 
    Dim StartX As Single, StartY As Single, Moving As Boolean
 
'--------------------
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  If Button <> 1 Then Exit Sub
  StartX = X
  StartY = Y
  Moving = True

End Sub
 
'--------------------
 
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

  If Moving then Move Left + (X - StartX), Top + (Y - StartY)

End Sub
 
'--------------------
 
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Moving = False

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Jan 27, 2010 at 5:15 p.m. EST
  • ∞ VB6: Compact Access DB with ADO 
    Public Function DbCompact(oldDb As String, Optional bakDb As String = "") As Integer

  'Needs Microsoft Jet and Replication Objects Library
  'Needs Microsoft ActiveX Data Objects Library
  'Needs Microsoft Scripting Runtime

  'Returns 0 if OK, -1 if FAIL

  DbCompact = -1

  On Error GoTo noDbOk

  Dim j As JetEngine
  Dim fso As FileSystemObject
  Dim jStr As String, newDb As String

  Set fso = New FileSystemObject
  If Not fso.FileExists(oldDb) Then Exit Sub

  Set j = New JetEngine

  jStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
  newDb = App.Path & "\tmpDb.mdb"

  j.CompactDatabase jStr & oldDb, jStr & newDb

  If Trim(bakDb) <> "" Then
    If fso.FileExists(bakDb) Then fso.DeleteFile bakDb
    fso.MoveFile oldDb, bakDb
  Else
    fso.DeleteFile oldDb
  End If
  fso.MoveFile newDb, oldDb

  DbCompact = 0

noDbOk:

  Set fso = Nothing
  Set j = Nothing

End Sub

    copy | embed

    0 comments - tagged in  posted by beccoblu on Jan 27, 2010 at 11:16 a.m. EST
Sign up to create your own snipts, or login.