Attribute VB_Name = "modRoutines"
Option Explicit
Option Base 0

Private m_CN                    As ADODB.Connection
Private m_RS                    As ADODB.Recordset
Private m_ST                    As ADODB.Stream
Private m_Login                 As Login

Sub Main()
    SetDEnvConn
    frmLogin.show
End Sub

Public Sub SetDEnvConn()
    Set m_Login = New Login
    m_Login.MyDBConnection
End Sub

Public Function Acos(x As Single) As Single
  If (Abs(x) >= 1) Then
    x = 0.9999 * (x / Abs(x))
  End If
  Acos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Function

Public Function function_sigmoid(x As Single) As Single
  function_sigmoid = (1# / (1# + Exp(-x)))
End Function

Public Function ProcStringTo(ByVal pString As String) As String
    ProcStringTo = Replace(pString, "\", "\\")
    ProcStringTo = Replace(ProcStringTo, "'", "\'")
End Function

Public Function CapFrame(ByRef PicCap As PictureBox) As StdPicture

    Dim hCapWinDC       As Long
    Dim hBitmap         As Long
    Dim hDC             As Long
    Dim hOldBMP         As Long
    Dim r               As Long
    
    PicCap = LoadPicture(EMPTY_STRING)
    hCapWinDC = GetDC(hCapWin)
    hBitmap = CreateCompatibleBitmap(hCapWinDC, wF, hF)
    hDC = CreateCompatibleDC(hCapWinDC)
    hOldBMP = SelectObject(hDC, hBitmap)
    
    r = BitBlt(hDC, 0, 0, wF, hF, hCapWinDC, 0, 0, vbSrcCopy)
    r = BitBlt(PicCap.hDC, 0, 0, PicCap.ScaleWidth, PicCap.ScaleHeight, hDC, 0, 0, vbSrcCopy)
    PicCap.Refresh
    Set CapFrame = PicCap.image
    
    r = SelectObject(hDC, hOldBMP)
    r = DeleteDC(hDC)

End Function

Public Function CaptureClient(hWnd As Long, fLeft As Long, fTop As Long, sWidth As Long, sHeight As Long) As Picture

    Clipboard.Clear
    Clipboard.SetData CaptureWindow(hWnd, True, fLeft, fTop, sWidth, sHeight)
    SavePicture Clipboard.GetData(vbCFBitmap), App.Path & "\Image.jpg"
    Set CaptureClient = LoadPicture(App.Path & "\Image.jpg")
    
End Function

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal bClient As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

    Dim hDCMemory               As Long
    Dim hBmp                    As Long
    Dim hBmpPrev                As Long
    Dim r                       As Long
    Dim hDCSrc                  As Long
    Dim hPal                    As Long
    Dim hPalPrev                As Long
    Dim RasterCapsScrn          As Long
    Dim HasPaletteScrn          As Long
    Dim PaletteSizeScrn         As Long
    Dim LogPal                  As LOGPALETTE
    
    If bClient Then
        hDCSrc = GetDC(hWndSrc)
    Else
        hDCSrc = GetWindowDC(hWndSrc)
    End If
    
    hDCMemory = CreateCompatibleDC(hDCSrc)
    
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)

        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)

    End If

    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcInvert)

    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndSrc, hDCSrc)

    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)

End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

    Dim r   As Long
    Dim Pic As PicBmp
    Dim IPic          As IPicture
    Dim IID_IDispatch As GUID
    
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    
    With Pic
        .Size = Len(Pic)          ' Length of structure
        .Type = vbPicTypeBitmap   ' Type of Picture (bitmap)
        .hBmp = hBmp              ' Handle to bitmap
        .hPal = hPal              ' Handle to palette (may be null)
    End With
    
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    
    Set CreateBitmapPicture = IPic

End Function

Public Sub AlwaysOnTop(This As Form, SetOnTop As Boolean)

    Dim lFlag As Long

    lFlag = IIf((SetOnTop = True), HWND_TOPMOST, HWND_NOTOPMOST)

    SetWindowPos This.hWnd, lFlag, _
        This.left / Screen.TwipsPerPixelX, _
        This.top / Screen.TwipsPerPixelY, _
        This.width / Screen.TwipsPerPixelX, _
        This.height / Screen.TwipsPerPixelY, _
        SWP_NOACTIVATE Or SWP_SHOWWINDOW

End Sub

Public Function ZeroFill(ByVal siCurString As String, Optional ByVal niLength As Integer = 10) As String
    On Error Resume Next
    ZeroFill = String(niLength - Len(siCurString), "0") & siCurString
End Function

Function ListIndex(ByRef Combo As ComboBox, ByVal Text As String) As Integer

    Dim ni  As Integer
    ListIndex = -1
    
    For ni = 0 To Combo.ListCount - 1
        If StrComp(Combo.List(ni), Text, vbTextCompare) = 0 Then
            ListIndex = ni
            Exit Function
        End If
    Next

End Function

Public Sub SelectTextBox(ByVal tBox As TextBox)
    tBox.SetFocus
    tBox.SelStart = 0
    tBox.SelLength = Len(tBox.Text)
End Sub

Public Sub ClearEntries(ByVal This As Form)

    Dim Ctrl As Control
    
    For Each Ctrl In This.Controls
        If TypeOf Ctrl Is TextBox Then
            Ctrl.Text = EMPTY_STRING
        ElseIf TypeOf Ctrl Is ComboBox Then
            Ctrl.ListIndex = -1
        ElseIf TypeOf Ctrl Is DTPicker Then
            Ctrl.value = Date
        ElseIf TypeOf Ctrl Is CheckBox Then
            Ctrl.value = vbUnchecked
        End If
    Next

End Sub


Public Sub DestroyObj()

    If Not m_CN Is Nothing Then Set m_CN = Nothing
    If Not m_RS Is Nothing Then Set m_RS = Nothing
    If Not m_ST Is Nothing Then Set m_ST = Nothing
    If Not m_Login Is Nothing Then Set m_Login = Nothing

End Sub
