1971 lines
61 KiB
Plaintext
1971 lines
61 KiB
Plaintext
********************************************************************************
|
|
*!* ctl32_functions.prg
|
|
********************************************************************************
|
|
#Include ctl32.h
|
|
|
|
If Not Sys(16) $ Upper(Set("Procedure")) Then
|
|
Set Procedure To Sys(16) Additive
|
|
Endif
|
|
|
|
Return
|
|
|
|
********************************************************************************
|
|
*!* ctlClientToScreen(nhWnd, @nX, @nY)
|
|
********************************************************************************
|
|
*!* Returns client coords x, y translated into screen coords x, y
|
|
********************************************************************************
|
|
Function ctlClientToScreen(pnHWnd As Integer, pnX As Integer, pnY As Integer)
|
|
|
|
Local ;
|
|
m.lcPoint As String, ;
|
|
m.lnRetVal As Integer
|
|
|
|
m.lcPoint = BinToC(m.pnX, "4RS") + BinToC(m.pnY, "4RS")
|
|
m.lnRetVal = apiClientToScreen(m.pnHWnd, @m.lcPoint)
|
|
|
|
m.pnX = CToBin(Substr(m.lcPoint , 1, 4), "4RS")
|
|
m.pnY = CToBin(Substr(m.lcPoint , 5, 4), "4RS")
|
|
|
|
Return m.lnRetVal <> 0
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlComRegister(cFileName)
|
|
********************************************************************************
|
|
*!* Registers a self registering dll or activex
|
|
********************************************************************************
|
|
Function ctlComRegister(pcFileName As String)
|
|
|
|
Local ;
|
|
m.lnHandle As Integer, ;
|
|
m.llRetVal As Boolean
|
|
|
|
m.llRetVal = FALSE
|
|
|
|
m.lnHandle = apiLoadLibrary(m.pcFileName)
|
|
|
|
If m.lnHandle <> 0 Then
|
|
|
|
If apiGetProcAddress(m.lnHandle, "DllRegisterServer") <> 0
|
|
|
|
Declare Integer DllRegisterServer In (m.pcFileName) ;
|
|
As DllRegisterServer_2CC11JLUG
|
|
|
|
If DllRegisterServer_2CC11JLUG() = S_OK Then
|
|
m.llRetVal = TRUE
|
|
Endif
|
|
|
|
Clear Dlls DllRegisterServer_2CC11JLUG
|
|
Endif
|
|
apiFreeLibrary(m.lnHandle)
|
|
Endif
|
|
Return m.llRetVal
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlComUnregister(cFileName)
|
|
********************************************************************************
|
|
*!* Unregisters a self registering dll or activex
|
|
********************************************************************************
|
|
Function ctlComUnregister(m.pcFileName As String)
|
|
|
|
Local ;
|
|
m.lnHandle As Integer, ;
|
|
m.llRetVal As Boolean
|
|
|
|
m.llRetVal = FALSE
|
|
|
|
m.lnHandle = apiLoadLibrary(m.pcFileName)
|
|
|
|
If m.lnHandle <> 0 Then
|
|
|
|
If apiGetProcAddress(m.lnHandle, "DllRegisterServer") <> 0
|
|
|
|
Declare Integer DllUnregisterServer In (m.pcFileName) ;
|
|
As DllUnregisterServer_2CC11JLUG
|
|
|
|
If DllUnregisterServer_2CC11JLUG() = S_OK Then
|
|
m.llRetVal = TRUE
|
|
Endif
|
|
|
|
Clear Dlls DllUnregisterServer_2CC11JLUG
|
|
|
|
Endif
|
|
apiFreeLibrary(m.lnHandle)
|
|
Endif
|
|
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlCToLargeInteger(cLargeInt)
|
|
********************************************************************************
|
|
*!* Converts a large integer binary value (8 bytes) to a VFP number
|
|
********************************************************************************
|
|
Function ctlCToLargeInteger(pcLargeInt As String)
|
|
|
|
Local ;
|
|
lnLow As Integer, ;
|
|
lnHigh As Integer, ;
|
|
lnLargeInt As Integer
|
|
|
|
m.lnLow = CToBin(Left(m.pcLargeInt, 4), "4rs")
|
|
m.lnHigh = CToBin(Right(m.pcLargeInt, 4), "4rs")
|
|
m.lnLargeInt = ctlLowHighToLargeInteger(m.lnLow, m.lnHigh)
|
|
|
|
Return m.lnLargeInt
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetOsVersion()
|
|
********************************************************************************
|
|
*!* Returns the operating system version in a NTDDI format
|
|
********************************************************************************
|
|
*!* NTDDI version constants
|
|
*!* /http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=2095548&SiteID=1
|
|
*!* #define NTDDI_WIN2K 05000000
|
|
*!* #define NTDDI_WIN2KSP1 05000100
|
|
*!* #define NTDDI_WIN2KSP2 05000200
|
|
*!* #define NTDDI_WIN2KSP3 05000300
|
|
*!* #define NTDDI_WIN2KSP4 05000400
|
|
|
|
*!* #define NTDDI_WINXP 05010000
|
|
*!* #define NTDDI_WINXPSP1 05010100
|
|
*!* #define NTDDI_WINXPSP2 05010200
|
|
*!* #define NTDDI_WINXPSP3 05010300
|
|
*!* #define NTDDI_WINXPSP4 05010400
|
|
|
|
*!* #define NTDDI_WS03 05020000
|
|
*!* #define NTDDI_WS03SP1 05020100
|
|
*!* #define NTDDI_WS03SP2 05020200
|
|
*!* #define NTDDI_WS03SP3 05020300
|
|
*!* #define NTDDI_WS03SP4 05020400
|
|
|
|
*!* #define NTDDI_WIN6 06000000
|
|
*!* #define NTDDI_WIN6SP1 06000100
|
|
*!* #define NTDDI_WIN6SP2 06000200
|
|
*!* #define NTDDI_WIN6SP3 06000300
|
|
*!* #define NTDDI_WIN6SP4 06000400
|
|
*!* #define NTDDI_VISTA NTDDI_WIN6
|
|
*!* #define NTDDI_VISTASP1 NTDDI_WIN6SP1
|
|
*!* #define NTDDI_VISTASP2 NTDDI_WIN6SP2
|
|
*!* #define NTDDI_VISTASP3 NTDDI_WIN6SP3
|
|
*!* #define NTDDI_VISTASP4 NTDDI_WIN6SP4
|
|
*!* #define NTDDI_WS08 NTDDI_WIN6SP1
|
|
*!* #define NTDDI_WS08SP2 NTDDI_WIN6SP2
|
|
*!* #define NTDDI_WS08SP3 NTDDI_WIN6SP3
|
|
*!* #define NTDDI_WS08SP4 NTDDI_WIN6SP4
|
|
*!* #define NTDDI_LONGHORN NTDDI_VISTA
|
|
********************************************************************************
|
|
Function ctlGetOsVersion()
|
|
Return Val(Os(3)) * 1000000 + Val(Os(4)) * 10000 + Val(Os(8)) * 100 + Val(Os(9))
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCaretPos(@nX, @nY)
|
|
********************************************************************************
|
|
*!* Returns the position of the caret in CLIENT coordinates.
|
|
********************************************************************************
|
|
Function ctlGetCaretPos(pnX As Integer, pnY As Integer)
|
|
|
|
Local ;
|
|
m.lcPoint As String, ;
|
|
m.lnRetVal As Integer
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
m.lnRetVal = apiGetCaretPos(@m.lcPoint)
|
|
m.pnX = CToBin(Substr(m.lcPoint, 1, 4), "4RS")
|
|
m.pnY = CToBin(Substr(m.lcPoint, 5, 4), "4RS")
|
|
Return m.lnRetVal <> 0
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCaretPosX()
|
|
********************************************************************************
|
|
*!* Returns the X coordinate of the caret position in CLIENT coordinates
|
|
********************************************************************************
|
|
Function ctlGetCaretPosX()
|
|
|
|
Local m.lcPoint As String
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
apiGetCaretPos(@m.lcPoint)
|
|
Return CToBin(Substr(m.lcPoint, 1, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCaretPosY()
|
|
********************************************************************************
|
|
*!* Returns the Y coordinate of the caret position in CLIENT coordinates
|
|
********************************************************************************
|
|
Function ctlGetCaretPosY()
|
|
|
|
Local m.lcPoint As String
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
apiGetCaretPos(@m.lcPoint)
|
|
Return CToBin(Substr(m.lcPoint, 5, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCursorPos(@nX, @nY)
|
|
********************************************************************************
|
|
*!* Returns the position of the mouse cursor in SCREEN coordinates.
|
|
********************************************************************************
|
|
Function ctlGetCursorPos(m.pnX As Integer, m.pnY As Integer)
|
|
|
|
Local ;
|
|
m.lcPoint As String, ;
|
|
m.lnRetVal As Integer
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
m.lnRetVal = apiGetCursorPos(@m.lcPoint)
|
|
m.pnX = CToBin(Substr(m.lcPoint, 1, 4), "4RS")
|
|
m.pnY = CToBin(Substr(m.lcPoint, 5, 4), "4RS")
|
|
Return m.lnRetVal <> 0
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCursorPosX()
|
|
********************************************************************************
|
|
*!* Returns the x coordinate position of the mouse cursor in SCREEN coordinates.
|
|
********************************************************************************
|
|
Function ctlGetCursorPosX()
|
|
|
|
Local m.lcPoint As String
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
apiGetCursorPos(@m.lcPoint)
|
|
Return CToBin(Substr(m.lcPoint, 1, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetCursorPosY()
|
|
********************************************************************************
|
|
*!* Returns the y coordinate position of the mouse cursor in SCREEN coordinates.
|
|
********************************************************************************
|
|
Function ctlGetCursorPosY()
|
|
|
|
Local m.lcPoint As String
|
|
|
|
m.lcPoint = 0h0000000000000000
|
|
apiGetCursorPos(@m.lcPoint)
|
|
Return CToBin(Substr(m.lcPoint, 5, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlHiMetricToPixelsX(nHiMetricX)
|
|
********************************************************************************
|
|
*!* :http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_20024530.html
|
|
*!* HIMETRIC / 2540 = INCHES
|
|
*!* INCHES * 1440 = TWIPS
|
|
*!* TWIPS / TwipsPerPixel = PIXELS
|
|
********************************************************************************
|
|
Function ctlHiMetricToPixelsX(m.pnHiMetricX As Integer)
|
|
Return Round(m.pnHiMetricX / 2540 * 1440 / ctlTwipsPerPixelX(), 0)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* :http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_20024530.html
|
|
*!* HIMETRIC / 2540 = INCHES
|
|
*!* INCHES * 1440 = TWIPS
|
|
*!* TWIPS / TwipsPerPixel = PIXELS
|
|
********************************************************************************
|
|
Function ctlHiMetricToPixelsY(m.pnHiMetricY As Integer)
|
|
Return Round(m.pnHiMetricY / 2540 * 1440 / ctlTwipsPerPixelY(), 0)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlIsObjectInPage(oControl)
|
|
********************************************************************************
|
|
*!* Determines if a control is contained in a page somewhere
|
|
*!* along its object hierarchy
|
|
********************************************************************************
|
|
Function ctlIsObjectInPage(m.poControl As Control)
|
|
|
|
Local ;
|
|
m.llIsInPage As Boolean, ;
|
|
m.loControl As Control
|
|
|
|
m.llIsInPage = FALSE
|
|
|
|
m.loControl = m.poControl
|
|
Do While Inlist(Upper(m.loControl.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
If Upper(m.loControl.BaseClass) == "PAGE" Then
|
|
m.llIsInPage = TRUE
|
|
Exit
|
|
Endif
|
|
m.loControl = m.loControl.Parent
|
|
Enddo
|
|
m.loControl = .Null.
|
|
m.poControl = .Null.
|
|
|
|
Return m.llIsInPage
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlIsThemeActive(m.poObject As Object)
|
|
If Vartype(m.poObject) = T_OBJECT Then
|
|
|
|
Local ;
|
|
m.loForm As Form, ;
|
|
m.llFormThemeActive As Boolean, ;
|
|
m.llControlThemeActive As Boolean
|
|
|
|
*!* Get theme status of object:
|
|
Do Case
|
|
Case Pemstatus(m.poObject, "ctlThemes", CON_PEMSTAT_DEFINED)
|
|
m.llControlThemeActive = m.poObject.ctlThemes
|
|
Case Pemstatus(m.poObject, "Themes", CON_PEMSTAT_DEFINED)
|
|
m.llControlThemeActive = m.poObject.Themes
|
|
Otherwise
|
|
m.llControlThemeActive = TRUE
|
|
Endcase
|
|
|
|
*!* Get theme status of parent form
|
|
m.loForm = m.poObject
|
|
|
|
Do While Inlist(Upper(m.loForm.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
m.loForm = m.loForm.Parent
|
|
Enddo
|
|
|
|
m.llFormThemeActive = m.loForm.Themes
|
|
|
|
m.loForm = .Null.
|
|
m.poObject = .Null.
|
|
|
|
Return apiIsThemeActive() = 1 And _Screen.Themes And m.llFormThemeActive And m.llControlThemeActive
|
|
Else
|
|
Return apiIsThemeActive() <> 0
|
|
Endif
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Allocates a block of memory of m.pnBytes
|
|
*!* Returns a handle to the allocated memory
|
|
*!* Must be freed after use
|
|
********************************************************************************
|
|
Function ctlMemAlloc(m.pnBytesToAllocate As Integer)
|
|
Return apiHeapAlloc(apiGetProcessHeap(), HEAP_ZERO_MEMORY, m.pnBytesToAllocate)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Frees a block of memory allocated with ctlMemAlloc
|
|
********************************************************************************
|
|
Function ctlMemFree(m.pnMem As Integer)
|
|
Return apiHeapFree(apiGetProcessHeap(), 0, m.pnMem)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Reads from a memory handle exactly m.pnBytes
|
|
********************************************************************************
|
|
Function ctlMemRead(m.pnMem As Integer, m.pnBytesToRead As Integer)
|
|
If Vartype(m.pnMem) <> T_NUMERIC Or m.pnMem <= 0 Then
|
|
Return ""
|
|
Endif
|
|
If Vartype(m.pnBytesToRead) <> T_NUMERIC Or m.pnBytesToRead <= 0 Then
|
|
m.pnBytesToRead = apiHeapSize(apiGetProcessHeap(), 0, m.pnMem)
|
|
Endif
|
|
Return Sys(2600, m.pnMem, m.pnBytesToRead)
|
|
Endfunc
|
|
|
|
|
|
********************************************************************************
|
|
*!* Returns the size of a block of memory allocated with ctlMemAlloc
|
|
*!* Returns -1 on failure
|
|
********************************************************************************
|
|
Function ctlMemSize(m.pnMem As Integer)
|
|
Return apiHeapSize(apiGetProcessHeap(), 0, m.pnMem)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Writes to a memory heap handle, m.pnBytes of m.pcData
|
|
*!* pads with NULAs if len(m.pcData) < m.pnBytes
|
|
********************************************************************************
|
|
Function ctlMemWrite(m.pnMem As Integer, m.pcData As String, m.pnBytesToWrite As Integer)
|
|
If Vartype(m.pcData) = T_NUMERIC Then
|
|
m.pcData = BinToC(m.pcData, "4rs")
|
|
Endif
|
|
If Vartype(m.pnBytesToWrite) = T_NUMERIC And m.pnBytesToWrite > Len(m.pcData) Then
|
|
m.pcData = m.pcData + Replicate(NULCHAR, m.pnBytesToWrite - Len(m.pcData))
|
|
Else
|
|
m.pnBytesToWrite = Len(m.pcData)
|
|
Endif
|
|
If m.pnMem = 0 Then
|
|
m.pnMem = ctlMemAlloc(m.pnBytesToWrite)
|
|
Endif
|
|
m.pcData = Sys(2600, m.pnMem, m.pnBytesToWrite, m.pcData)
|
|
Return m.pnMem
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* converts an integer to an unsigned integer
|
|
********************************************************************************
|
|
Function ctlIntegerToUnsigned(m.pnValue As Integer)
|
|
Local lnRetVal
|
|
|
|
If m.pnValue < 0 Then
|
|
m.lnRetVal = m.pnValue + 4294967296
|
|
Else
|
|
m.lnRetVal = m.pnValue
|
|
Endif
|
|
|
|
Return m.lnRetVal
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* pcValueToReturn can be: T, B, L, R for Top, Bottom, Left, Right
|
|
*!* This replaces OBJTOCLIENT that has bugs with pageframes
|
|
********************************************************************************
|
|
Function ctlObjToClient(m.poControl As Control, m.pcValueToReturn As String)
|
|
|
|
Local m.lnPosition As Integer
|
|
|
|
m.pcValueToReturn = Upper(m.pcValueToReturn)
|
|
m.lnPosition = 0
|
|
|
|
Do Case
|
|
|
|
Case m.pcValueToReturn $ "TB"
|
|
*!* 20070711 Modified to account for toolbars
|
|
Do While Inlist(Upper(m.poControl.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
If Pemstatus(m.poControl, "Top", CON_PEMSTAT_DEFINED) Then
|
|
m.lnPosition = m.lnPosition + m.poControl.Top
|
|
Endif
|
|
If Upper(m.poControl.BaseClass) == "PAGE" Then
|
|
If m.poControl.Parent.TabOrientation = CON_TABOR_TOP Then && Top
|
|
m.lnPosition = m.lnPosition + ;
|
|
m.poControl.Parent.Height - ;
|
|
m.poControl.Parent.PageHeight - ;
|
|
m.poControl.Parent.BorderWidth * 2
|
|
Else
|
|
m.lnPosition = m.lnPosition + 1
|
|
Endif
|
|
Endif
|
|
m.poControl = m.poControl.Parent
|
|
Enddo
|
|
|
|
If m.pcValueToReturn == "B" Then
|
|
m.lnPosition = m.lnPosition + This.Height
|
|
Endif
|
|
|
|
Case m.pcValueToReturn $ "LR"
|
|
*!* 20070711 Modified to account for toolbars
|
|
Do While Inlist(Upper(m.poControl.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
If Pemstatus(m.poControl, "Left", CON_PEMSTAT_DEFINED) Then
|
|
m.lnPosition = m.lnPosition + m.poControl.Left
|
|
Endif
|
|
If Upper(m.poControl.BaseClass) == "PAGE"
|
|
If m.poControl.Parent.TabOrientation = CON_TABOR_LEFT Then && Left
|
|
m.lnPosition = m.lnPosition + ;
|
|
m.poControl.Parent.Width - ;
|
|
m.poControl.Parent.PageWidth - ;
|
|
m.poControl.Parent.BorderWidth * 2
|
|
Else
|
|
m.lnPosition = m.lnPosition + 1
|
|
Endif
|
|
Endif
|
|
m.poControl = m.poControl.Parent
|
|
Enddo
|
|
|
|
If m.pcValueToReturn == "R" Then
|
|
m.lnPosition = m.lnPosition + This.Width
|
|
Endif
|
|
|
|
Endcase
|
|
|
|
Return m.lnPosition
|
|
Endfunc
|
|
|
|
*!* * Inverse of VFP's DTOS() function.
|
|
Function ctlSTOD(m.pcDate As String)
|
|
Local m.ldDate As Date
|
|
m.ldDate = Date(Val(Substr(m.pcDate,1,4)), Val(Substr(m.pcDate,5,2)), Val(Substr(m.pcDate,7,2)))
|
|
Return m.ldDate
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts a numeric value into a string that represents the number expressed
|
|
*!* as a size value in bytes, kilobytes, megabytes, or gigabytes, depending on the size.
|
|
*!* API StrFormatByteSize only work for files up to 4GB
|
|
*!* Local ;
|
|
*!* m.lcBuffer As String
|
|
*!* m.lcBuffer = Space(254)
|
|
*!* StrFormatByteSize(m.pnSizeInBytes, @m.lcBuffer, Len(m.lcBuffer))
|
|
*!* * Remove NUL CHAR
|
|
*!* m.lcBuffer = Left(m.lcBuffer, At(NULA, m.lcBuffer) - 1)
|
|
*!* Return m.lcBuffer
|
|
********************************************************************************
|
|
Function ctlStrFormatByteSize(m.pnSizeInBytes As Number)
|
|
Local ;
|
|
m.lnSize As Integer, ;
|
|
m.lcUnit As String
|
|
|
|
Do Case
|
|
Case m.pnSizeInBytes < 999 && Bytes
|
|
m.lnSize = m.pnSizeInBytes
|
|
m.lcUnit = " Bytes"
|
|
Case m.pnSizeInBytes < 1024^1 * 999 && KiloBytes
|
|
m.lnSize = m.pnSizeInBytes / 1024^1
|
|
m.lcUnit = " KB"
|
|
Case m.pnSizeInBytes < 1024^2 * 999 && MegaBytes
|
|
m.lnSize = m.pnSizeInBytes / 1024^2
|
|
m.lcUnit = " MB"
|
|
Case m.pnSizeInBytes < 1024^3 * 999 && GigaBytes
|
|
m.lnSize = m.pnSizeInBytes / 1024^3
|
|
m.lcUnit = " GB"
|
|
Otherwise
|
|
m.lnSize = m.pnSizeInBytes / 1024^4 && TeraBytes
|
|
m.lcUnit = " TB"
|
|
Endcase
|
|
|
|
Do Case
|
|
Case m.lnSize > 100
|
|
m.lnSize = Round(m.lnSize , 0)
|
|
Case m.lnSize > 10
|
|
m.lnSize = Round(m.lnSize , 1)
|
|
Otherwise
|
|
m.lnSize = Round(m.lnSize , 2)
|
|
Endcase
|
|
|
|
Return Transform(m.lnSize) + m.lcUnit
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlStrFormatSeconds(pnSeconds)
|
|
|
|
m.pnSeconds = Round(m.pnSeconds, 0)
|
|
|
|
Local ;
|
|
m.lcHours As String, ;
|
|
m.lcMinutes As String, ;
|
|
m.lcSeconds As String
|
|
|
|
If Int(m.pnSeconds / 3600) > 0 Then
|
|
m.lcHours = Padl(Alltrim(Str(Int(m.pnSeconds / 3600))), 2, "0") + ":"
|
|
Else
|
|
m.lcHours = ""
|
|
Endif
|
|
|
|
m.lcMinutes = Padl(Alltrim(Str(Int((m.pnSeconds % 3600) / 60))), 2, "0") + ":"
|
|
m.lcSeconds = Padl(Alltrim(Str((m.pnSeconds % 3600) % 60)), 2, "0")
|
|
|
|
Return m.lcHours + m.lcMinutes + m.lcSeconds
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts an unsigned integer to an integer.
|
|
********************************************************************************
|
|
Function ctlUnsignedToInteger(m.pnValue As Integer)
|
|
|
|
Local m.lnRetVal As Integer
|
|
|
|
If m.pnValue <= 2147483647 Then
|
|
m.lnRetVal = m.pnValue
|
|
Else
|
|
m.lnRetVal= m.pnValue - 4294967296
|
|
Endif
|
|
|
|
Return m.lnRetVal
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlFClose(pnFileHandle As Integer)
|
|
|
|
Local ;
|
|
lnApiRetVal As Integer, ;
|
|
llRetVal As Boolean
|
|
|
|
m.lnApiRetVal = apiCloseHandle(m.pnFileHandle)
|
|
|
|
If m.lnApiRetVal = 0 Then
|
|
m.llRetVal = FALSE
|
|
Else
|
|
m.llRetVal = TRUE
|
|
Endif
|
|
|
|
Return m.llRetVal
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlFgets(nFileHandle [, nBytes])
|
|
********************************************************************************
|
|
*!* Returns a series of bytes from a file or a communication port opened with a
|
|
*!* low-level file function until it encounters a carriage return.
|
|
********************************************************************************
|
|
Function ctlFGets(pnFileHandle As Integer, pnBytesToRead As Integer)
|
|
|
|
Local ;
|
|
lcByteString As String, ;
|
|
lnBytesRead As Integer, ;
|
|
lnApiRetVal As Integer, ;
|
|
lnOverlapped As Integer, ;
|
|
lnCrLfPos As Integer, ;
|
|
lnOffset As Integer
|
|
|
|
If Vartype(m.pnBytesToRead) # T_NUMERIC Then
|
|
m.pnBytesToRead = 254
|
|
Endif
|
|
|
|
m.lnBytesRead = 0
|
|
m.lcByteString = Space(m.pnBytesToRead)
|
|
m.lnOverlapped = 0
|
|
|
|
m.lnApiRetVal = apiReadFile(m.pnFileHandle, ;
|
|
@m.lcByteString, ;
|
|
m.pnBytesToRead , ;
|
|
@m.lnBytesRead , ;
|
|
m.lnOverlapped)
|
|
|
|
If m.lnApiRetVal = 0 Then
|
|
m.lcByteString = ""
|
|
Else
|
|
m.lcByteString = Left(m.lcByteString, m.lnBytesRead)
|
|
Endif
|
|
|
|
*!* Now search for CRLF in the string:
|
|
m.lnCrLfPos = At(CRLF, m.lcByteString)
|
|
|
|
*!* if we find a CRLF in the string
|
|
If m.lnCrLfPos <> 0 Then
|
|
|
|
*!* Set file pointer for next read to after CRLF
|
|
m.lnOffset = (m.lnBytesRead - m.lnCrLfPos - 1) * (-1)
|
|
ctlFSeek(m.pnFileHandle, m.lnOffset , 1)
|
|
|
|
*!* Remove trailing characters after CRLF
|
|
m.lcByteString = Left(m.lcByteString, m.lnCrLfPos - 1)
|
|
Endif
|
|
|
|
Return m.lcByteString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlFileTimeToDateTime(poFileTime As _FILETIME)
|
|
|
|
Local ;
|
|
loSystemTime As _SYSTEMTIME, ;
|
|
ltFileDateTime As Datetime
|
|
|
|
m.loSystemTime = Createobject("_SYSTEMTIME")
|
|
|
|
If apiFileTimeToSystemTime(m.poFileTime.Address, m.loSystemTime.Address) = 1 Then
|
|
With m.loSystemTime
|
|
m.ltFileDateTime = Datetime(.wYear, .wMonth, .wDay, .wHour, .wMinute, .wSecond)
|
|
Endwith
|
|
Else
|
|
m.ltFileDateTime = Ctot("")
|
|
Endif
|
|
|
|
m.loSystemTime = .Null.
|
|
|
|
Return m.ltFileDateTime
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlFontHeightToPoints(pnHeight As Integer)
|
|
|
|
Local ;
|
|
lnDc As Integer, ;
|
|
lnLogPixelsY As Integer
|
|
|
|
m.lnDc = apiGetDC(HWND_DESKTOP)
|
|
m.lnLogPixelsY = apiGetDeviceCaps(m.lnDc, LOGPIXELSY)
|
|
apiReleaseDC(HWND_DESKTOP, m.lnDc)
|
|
Return Round(72 * m.pnHeight / m.lnLogPixelsY * (-1), 0)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlFontPointsToHeight(pnPoints As Integer)
|
|
|
|
Local ;
|
|
lnDc As Integer, ;
|
|
lnLogPixelsY As Integer
|
|
|
|
m.lnDc = apiGetDC(HWND_DESKTOP)
|
|
m.lnLogPixelsY = apiGetDeviceCaps(m.lnDc, LOGPIXELSY)
|
|
apiReleaseDC(HWND_DESKTOP, m.lnDc)
|
|
Return apiMulDiv(m.pnPoints, m.lnLogPixelsY, 72) * (-1)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlFopen(cFilename [, nAttribute])
|
|
********************************************************************************
|
|
*!* 0 READ-ONLY BUFFERED
|
|
*!* 1 WRITE-ONLY BUFFERED
|
|
*!* 2 READ-WRITE BUFFERED
|
|
*!* 10 READ-ONLY UNBUFFERED
|
|
*!* 11 WRITE-ONLY UNBUFFERED
|
|
*!* 12 READ-WRITE UNBUFFERED
|
|
********************************************************************************
|
|
Function ctlFOpen(pcFileName As String, pnAttribute As Integer)
|
|
|
|
Local ;
|
|
lcFilename As String, ;
|
|
lnDesiredAccess As Integer, ;
|
|
lnShareMode As Integer, ;
|
|
lnSecurityAttributes As Integer, ;
|
|
lnCreationDisposition As Integer, ;
|
|
lnFlagsAndAttributes As Integer, ;
|
|
lnTemplateFile As Integer, ;
|
|
lnBufferFlag As Integer, ;
|
|
lnFileHandle As Integer
|
|
|
|
m.lcFilename = Alltrim(m.pcFileName)
|
|
|
|
If Vartype(m.pnAttribute) # T_NUMERIC Then
|
|
m.pnAttribute = 0
|
|
Endif
|
|
|
|
Do Case
|
|
Case m.pnAttribute = 0
|
|
m.lnDesiredAccess = GENERIC_READ
|
|
m.lnBufferFlag = 0
|
|
Case m.pnAttribute = 1
|
|
m.lnDesiredAccess = GENERIC_WRITE
|
|
m.lnBufferFlag = 0
|
|
Case m.pnAttribute = 2
|
|
m.lnDesiredAccess = Bitor(GENERIC_READ, GENERIC_WRITE)
|
|
m.lnBufferFlag = 0
|
|
Case m.pnAttribute = 10
|
|
m.lnDesiredAccess = GENERIC_READ
|
|
m.lnBufferFlag = FILE_FLAG_WRITE_THROUGH
|
|
Case m.pnAttribute = 11
|
|
m.lnDesiredAccess = GENERIC_WRITE
|
|
m.lnBufferFlag = FILE_FLAG_WRITE_THROUGH
|
|
Case m.pnAttribute = 12
|
|
m.lnDesiredAccess = Bitor(GENERIC_READ, GENERIC_WRITE)
|
|
m.lnBufferFlag = FILE_FLAG_WRITE_THROUGH
|
|
Otherwise
|
|
m.lnDesiredAccess = GENERIC_READ
|
|
m.lnBufferFlag = 0
|
|
Endcase
|
|
|
|
m.lnShareMode = 0
|
|
m.lnSecurityAttributes = 0
|
|
m.lnCreationDisposition = OPEN_EXISTING
|
|
m.lnFlagsAndAttributes = Bitor(FILE_ATTRIBUTE_NORMAL, m.lnBufferFlag)
|
|
m.lnTemplateFile = 0
|
|
|
|
m.lnFileHandle = apiCreateFile( ;
|
|
m.lcFilename, ;
|
|
m.lnDesiredAccess, ;
|
|
m.lnShareMode, ;
|
|
m.lnSecurityAttributes, ;
|
|
m.lnCreationDisposition, ;
|
|
m.lnFlagsAndAttributes, ;
|
|
m.lnTemplateFile)
|
|
|
|
Return m.lnFileHandle
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlFRead(pnFileHandle As Integer, pnBytesToRead As Integer)
|
|
|
|
Local ;
|
|
lcByteString As String, ;
|
|
lnBytesRead As Integer, ;
|
|
lnApiRetVal As Integer, ;
|
|
lnOverlapped As Integer
|
|
|
|
m.lnBytesRead = 0
|
|
m.lcByteString = Space(m.pnBytesToRead)
|
|
m.lnOverlapped = 0
|
|
|
|
m.lnApiRetVal = apiReadFile(m.pnFileHandle, ;
|
|
@m.lcByteString, ;
|
|
m.pnBytesToRead , ;
|
|
@m.lnBytesRead , ;
|
|
m.lnOverlapped)
|
|
|
|
If m.lnApiRetVal = 0 Then
|
|
m.lcByteString = ""
|
|
Else
|
|
m.lcByteString = Left(m.lcByteString, m.lnBytesRead)
|
|
Endif
|
|
|
|
Return m.lcByteString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* _Fseek(nFileHandle, nBytesMoved ", nRelativePosition")
|
|
*!* #DEFINE FILE_BEGIN 0
|
|
*!* #DEFINE FILE_CURRENT 1
|
|
*!* #DEFINE FILE_END 2
|
|
*!* #DEFINE INVALID_SET_FILE_POINTER -1
|
|
********************************************************************************
|
|
Function ctlFSeek(pnFileHandle As Integer, pnBytesMoved As Integer , pnRelativePosition As Integer)
|
|
|
|
Local ;
|
|
lnLow As Integer, ;
|
|
lnHigh As Integer, ;
|
|
lcNewFilePointer As String, ;
|
|
lnNewFilePointer As Integer, ;
|
|
lnApiRetVal As Integer
|
|
|
|
If Vartype(m.pnRelativePosition) # T_NUMERIC Then
|
|
m.pnRelativePosition = 0
|
|
Endif
|
|
|
|
*!* Split large integer into low unsigned and high signed
|
|
|
|
m.lnLow = 0
|
|
m.lnHigh = 0
|
|
ctlLargeIntegerToLowHigh(m.pnBytesMoved, @m.lnLow, @m.lnHigh)
|
|
|
|
m.lcNewFilePointer = Replicate(NULCHAR, 8)
|
|
|
|
m.lnApiRetVal = ;
|
|
apiSetFilePointerEx( ;
|
|
m.pnFileHandle , ;
|
|
m.lnLow , ;
|
|
m.lnHigh, ;
|
|
@m.lcNewFilePointer, ;
|
|
m.pnRelativePosition )
|
|
|
|
If m.lnApiRetVal = 0 Then
|
|
m.lnNewFilePointer = -1
|
|
Else
|
|
m.lnNewFilePointer = ctlCToLargeInteger(m.lcNewFilePointer)
|
|
Endif
|
|
|
|
Return m.lnNewFilePointer
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlFSize(cFilename|nFileHandle)
|
|
********************************************************************************
|
|
Function ctlFSize(puFnameOrFhandle As variant)
|
|
|
|
Local ;
|
|
m.lnFileSize As Integer, ;
|
|
m.llCloseFile As Boolean, ;
|
|
m.lnFileHandle As Integer, ;
|
|
m.lcLargeInt As String, ;
|
|
m.lnApiRetVal As Integer
|
|
|
|
m.lnFileSize = -1
|
|
m.lnFileHandle = HFILE_ERROR
|
|
m.llCloseFile = FALSE
|
|
|
|
Do Case
|
|
Case Vartype(m.puFnameOrFhandle) = T_NUMERIC
|
|
m.lnFileHandle = m.puFnameOrFhandle
|
|
|
|
Case Vartype(m.puFnameOrFhandle) = T_CHARACTER
|
|
m.llCloseFile = TRUE
|
|
m.lnFileHandle = ctlFOpen(m.puFnameOrFhandle, 0)
|
|
|
|
Otherwise
|
|
Return m.lnFileSize
|
|
Endcase
|
|
|
|
If m.lnFileHandle <> HFILE_ERROR
|
|
|
|
m.lcLargeInt = Replicate(NULCHAR, 8)
|
|
m.lnApiRetVal = apiGetFileSizeEx(m.lnFileHandle, @m.lcLargeInt)
|
|
|
|
If m.lnApiRetVal <> 0 Then
|
|
m.lnFileSize = ctlCToLargeInteger(m.lcLargeInt)
|
|
Endif
|
|
Endif
|
|
|
|
*!* Close file
|
|
If m.llCloseFile = TRUE
|
|
ctlFClose(m.lnFileHandle)
|
|
Endif
|
|
|
|
Return m.lnFileSize
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlFwrite(nFileHandle, cExpression [, nCharactersWritten])
|
|
********************************************************************************
|
|
Function ctlFWrite(m.pnFileHandle As Integer, m.pcExpression As String, m.pnCharactersWritten As Integer)
|
|
|
|
Local ;
|
|
m.lnBytesWritten As Integer, ;
|
|
m.lnOverlapped As Integer, ;
|
|
m.lnApiRetVal As Integer
|
|
|
|
m.lnBytesWritten = 0
|
|
m.lnOverlapped = 0
|
|
|
|
If Vartype(m.pnCharactersWritten) <> T_NUMERIC Then
|
|
m.pnCharactersWritten = Len(m.pcExpression)
|
|
Endif
|
|
|
|
m.lnApiRetVal = apiWriteFile(m.pnFileHandle, ;
|
|
m.pcExpression, ;
|
|
m.pnCharactersWritten , ;
|
|
@m.lnBytesWritten, ;
|
|
m.lnOverlapped)
|
|
|
|
Return m.lnBytesWritten
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlLargeIntegerToC(m.pnLargeInt As Integer)
|
|
|
|
Local ;
|
|
m.lnLow As Integer, ;
|
|
m.lnHigh As Integer, ;
|
|
m.lcLargeInt As String
|
|
|
|
m.lnLow = 0
|
|
m.lnHigh = 0
|
|
|
|
ctlLargeIntegerToLowHigh(m.pnLargeInt, @m.lnLow, @m.lnHigh)
|
|
m.lcLargeInt = BinToC(m.lnLow, "4rs") + BinToC(m.lnHigh, "4rs")
|
|
Return m.lcLargeInt
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlLargeIntegerToLowHigh(nLargeInt, @nLow, @nHigh)
|
|
********************************************************************************
|
|
Function ctlLargeIntegerToLowHigh(m.pnLargeInt, m.lnLow, m.lnHigh)
|
|
|
|
m.lnLow = m.pnLargeInt % 2^32
|
|
m.lnHigh = Int((m.pnLargeInt - m.lnLow) / 2^32)
|
|
|
|
If m.lnLow < 0 Then
|
|
m.lnLow = m.lnLow + 2^32
|
|
Endif
|
|
|
|
Return
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlLowHighToLargeInteger(pnLow As Integer, pnHigh As Integer)
|
|
|
|
Local lnLargeInt As Integer
|
|
|
|
If m.pnLow < 0 Then
|
|
m.pnLow = m.pnLow + 2^32
|
|
Endif
|
|
|
|
m.lnLargeInt = m.pnLow + m.pnHigh * 2^32
|
|
|
|
Return m.lnLargeInt
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetLangId
|
|
********************************************************************************
|
|
*!* pnLocale could be LOCALE_USER_DEFAULT, LOCALE_SYSTEM_DEFAULT
|
|
*!* /http://msdn.microsoft.com/library/default.asp?url=/library/en-us/intl/nls_34rz.asp
|
|
*!* /http://msdn.microsoft.com/library/default.asp?url=/library/en-us/intl/nls_8xo3.asp
|
|
*!* /http://msdn.microsoft.com/library/default.asp?url=/library/en-us/intl/nls_61df.asp
|
|
*!* Sets the value of strings that are language dependant.
|
|
********************************************************************************
|
|
Function ctlGetLangId(m.pnLocale As Integer, m.pnWhatToReturn As Integer)
|
|
|
|
Local ;
|
|
m.lnLocale As Integer, ;
|
|
m.lcLocaleInfo As String, ;
|
|
m.lnCharsRet As Integer, ;
|
|
m.lnLangID As Integer, ;
|
|
m.lnPrimaryLangID As Integer, ;
|
|
m.lnSubLangID As Integer, ;
|
|
m.lnRetVal As Integer
|
|
|
|
If Pcount() > 0 .And. Vartype(m.pnLocale) = T_NUMERIC Then
|
|
m.lnLocale = m.pnLocale
|
|
Else
|
|
m.lnLocale = LOCALE_SYSTEM_DEFAULT
|
|
Endif
|
|
|
|
m.lcLocaleInfo = Replicate(NULCHAR, 5)
|
|
m.lnCharsRet = apiGetLocaleInfo(m.pnLocale , LOCALE_ILANGUAGE, @m.lcLocaleInfo, Len(m.lcLocaleInfo))
|
|
*!* remove nul chars
|
|
m.lcLocaleInfo = Strtran(m.lcLocaleInfo, NULCHAR, "")
|
|
*!* m.lcLocaleInfo is now a character representation of a hex number
|
|
m.lnLangID = Evaluate("0x" + m.lcLocaleInfo)
|
|
*!* m.lnPrimaryLangID = Bitand(m.lnLangID, 0x3FF)
|
|
*!* m.lnSubLangID = Bitrshift(m.lnLangID, 10)
|
|
|
|
Do Case
|
|
Case Pcount() < 2 Or m.pnWhatToReturn = 1
|
|
m.lnRetVal = m.lnLangID
|
|
Case m.pnWhatToReturn = 2
|
|
m.lnRetVal = Bitand(m.lnLangID, 0x3FF)
|
|
Case m.pnWhatToReturn = 3
|
|
m.lnRetVal = Bitrshift(m.lnLangID, 10)
|
|
Otherwise
|
|
m.lnRetVal = m.lnLangID
|
|
Endcase
|
|
|
|
Return m.lnRetVal
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* pnLocale could be LOCALE_USER_DEFAULT, LOCALE_SYSTEM_DEFAULT
|
|
********************************************************************************
|
|
Function ctlGetPrimaryLangID(m.pnLocale As Integer)
|
|
Return ctlGetLangId(m.pnLocale, 2)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns the height of a certain string in the font selected into a hwnd
|
|
********************************************************************************
|
|
Function ctlGetStringHeightFromHwnd(m.pcString, m.pnHWnd)
|
|
|
|
Local ;
|
|
m.lnDc As Integer, ;
|
|
m.lnHeight As Integer, ;
|
|
m.lnWidth As Integer, ;
|
|
m.lcSize As String, ;
|
|
m.lnFont As Integer, ;
|
|
m.lnPrevFont As Integer
|
|
|
|
*!* Get font
|
|
m.lnFont = apiSendMessageInteger(m.pnHWnd, WM_GETFONT, 0, 0)
|
|
*!* Get DC
|
|
m.lnDc = apiGetDC(m.pnHWnd)
|
|
*!* Apply font to DC, we get previous font as result
|
|
m.lnPrevFont = apiSelectObject(m.lnDc, m.lnFont)
|
|
|
|
m.lcSize = Space(8)
|
|
|
|
apiGetTextExtentPoint32(m.lnDc, m.pcString, Len(m.pcString), @ m.lcSize)
|
|
|
|
m.lnWidth = CToBin(Substr(m.lcSize, 1, 4), "4RS") && Width
|
|
m.lnHeight = CToBin(Substr(m.lcSize, 5, 4), "4RS") && Height
|
|
|
|
*!* Restore previous font
|
|
apiSelectObject(m.lnDc, m.lnPrevFont )
|
|
|
|
*!* Release DC
|
|
apiReleaseDC(m.pnHWnd, m.lnDc)
|
|
|
|
Return m.lnWidth
|
|
Endfunc
|
|
|
|
Function ctlGetStringWidthFromHwnd(m.lcString, m.lnHwnd)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* pnLocale could be LOCALE_USER_DEFAULT, LOCALE_SYSTEM_DEFAULT
|
|
********************************************************************************
|
|
Function ctlGetSubLangID(m.pnLocale As Integer)
|
|
Return ctlGetLangId(m.pnLocale, 3)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetPrimaryLangIDFromLangID(m.pnLangID As Integer)
|
|
Return Bitand(m.pnLangID, 0x3FF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetSubLangIDFromLangID(m.pnLangID As Integer)
|
|
Return Bitrshift(m.pnLangID, 10)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetHostHWnd(Object)
|
|
********************************************************************************
|
|
*!* Returns the HWnd of the form that contains an object, if any
|
|
*!* If the object has no parent, returns _VFP.HWnd
|
|
*!* If the form is a top level form or has scrollbars,
|
|
*!* returns the HWnd of the inner window.
|
|
*!* Parameter can be a form, toolbar or control
|
|
********************************************************************************
|
|
Function ctlGetHostHWnd(m.poObject As Object)
|
|
|
|
Local m.nhWnd As Integer
|
|
|
|
*!* traverse the object hierarchy until we find the form:
|
|
*!* Modified 20070603 to check for toolbars
|
|
*!* Do While Inlist(Upper(m.poObject.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
*!* m.poObject = m.poObject.Parent
|
|
*!* Enddo
|
|
|
|
*!* 20080405 modified to check for HWnd property of parent
|
|
*!* and to check if parent is an object
|
|
|
|
*!* Check if we already have a form or toolbar:
|
|
If Inlist(Upper(m.poObject.BaseClass), "FORM", "TOOLBAR") Then
|
|
m.nhWnd = m.poObject.HWnd
|
|
Else
|
|
*!* Check if object is contained in another object:
|
|
If Type("m.poObject.Parent") = T_UNDEFINED Then
|
|
m.nhWnd = _vfp.HWnd
|
|
Else
|
|
*!* Get first parent:
|
|
m.poObject = m.poObject.Parent
|
|
|
|
*!* Traverse object hierarchy upwards until we find an object with a HWnd:
|
|
Do While Pemstatus(m.poObject, "HWnd", 5) = FALSE
|
|
If Type("m.poObject.Parent") = T_UNDEFINED Then
|
|
m.nhWnd = _vfp.HWnd
|
|
Exit
|
|
Else
|
|
m.poObject = m.poObject.Parent
|
|
Endif
|
|
Enddo
|
|
m.nhWnd = m.poObject.HWnd
|
|
Endif
|
|
Endif
|
|
|
|
*!* If we have a form, and the form is a top level form, or it has scrollbars,
|
|
*!* get hWnd of inner window:
|
|
If Upper(m.poObject.BaseClass) = "FORM" Then
|
|
If m.poObject.ShowWindow = 2 Or m.poObject.ScrollBars > 0 Then
|
|
*!* Get hWnd of client window of Top Level Form //Craig Boyd//
|
|
If Version(CON_VER_NUM) >= 900
|
|
m.nhWnd = Sys(2327, Sys(2325, Sys(2326, m.poObject.HWnd)))
|
|
Else
|
|
m.nhWnd = apiGetWindow(m.poObject.HWnd, GW_CHILD)
|
|
Endif
|
|
Endif
|
|
Endif
|
|
|
|
m.poObject = .Null.
|
|
Release m.poObject
|
|
|
|
Return m.nhWnd
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* ctlGetHostHWnd()
|
|
*!* Returns the HWnd of a form, or the HWnd of the inner window in case of
|
|
*!* top level forms or forms with scrollbars
|
|
*!* Parameter can be a form, toolbar or control
|
|
********************************************************************************
|
|
Function ctlGetHostHWnd(m.poObject As Object)
|
|
|
|
Local ;
|
|
m.loForm As Form, ;
|
|
m.nhWnd As Integer
|
|
|
|
*!* traverse the object hierarchy until we find the form:
|
|
*!* Modified 20070603 to check for toolbars
|
|
Do While Inlist(Upper(m.poObject.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
m.poObject = m.poObject.Parent
|
|
Enddo
|
|
|
|
m.loForm = m.poObject
|
|
m.poObject = Null
|
|
m.nhWnd = m.loForm.HWnd
|
|
|
|
*!* If the form is a top level form, or it has scrollbars, get hWnd of inner window:
|
|
If Upper(m.loForm.BaseClass) = "FORM" Then
|
|
If m.loForm.ShowWindow = 2 Or m.loForm.ScrollBars > 0 Then
|
|
*!* Get hWnd of client window of Top Level Form //Craig Boyd//
|
|
If Version(CON_VER_NUM) >= 900
|
|
m.nhWnd = Sys(2327, Sys(2325, Sys(2326, m.loForm.HWnd)))
|
|
Else
|
|
m.nhWnd = apiGetWindow(m.loForm.HWnd, GW_CHILD)
|
|
Endif
|
|
Endif
|
|
Endif
|
|
|
|
m.loForm = Null
|
|
|
|
Return m.nhWnd
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* int GET_X_LPARAM(
|
|
*!* LPARAM lParam
|
|
*!* );
|
|
*!* Parameters
|
|
*!* lParam
|
|
*!* Specifies the value to be converted.
|
|
*!* Return Value
|
|
*!* The return value is the low-order int of the specified value.
|
|
********************************************************************************
|
|
Function ctlGet_X_lParam(m.pnlParam As Integer)
|
|
Return Bitand(m.pnlParam, 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetXFromLparam(m.pnlParam As Integer)
|
|
Return Bitand(m.pnlParam, 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* int GET_Y_LPARAM(
|
|
*!* LPARAM lParam
|
|
*!* );
|
|
*!* Parameters
|
|
*!* lParam
|
|
*!* Specifies the value to be converted.
|
|
*!* Return Value
|
|
*!* The return value is the high-order int of the specified value.
|
|
********************************************************************************
|
|
Function ctlGet_Y_lParam(m.pnlParam As Integer)
|
|
Return Bitrshift(m.pnlParam, 16) && Bitand(Int(m.pnlParam / 0x10000), 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetUserName
|
|
Local m.lcBuffer, m.lnBufferLen
|
|
m.lcBufferLen = UNLEN + 1
|
|
m.lcBuffer = Replicate(NULCHAR, m.lcBufferLen)
|
|
apiGetUserName(@m.lcBuffer, @m.lcBufferLen)
|
|
Return Left(m.lcBuffer, m.lcBufferLen - 1)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetYFromLparam(m.pnlParam As Integer)
|
|
Return Bitrshift(m.pnlParam, 16) && Bitand(Int(m.pnlParam / 0x10000), 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlGetWindowProcedure(m.pnHWnd As Integer)
|
|
If Empty(m.pnHWnd) Then
|
|
m.pnHWnd = _vfp.HWnd
|
|
Endif
|
|
Return apiGetWindowLong(m.pnHWnd, GWL_WNDPROC)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* BYTE HIBYTE(
|
|
*!* Word wValue
|
|
*!* );
|
|
*!* Parameters
|
|
*!* wValue
|
|
*!* Specifies the Value To be converted.
|
|
*!* Return Value
|
|
*!* the Return Value Is the High-Order BYTE Of the specified Value.
|
|
********************************************************************************
|
|
Function ctlHiByte(m.pnlParam As Integer)
|
|
Return Bitrshift(m.pnlParam, 8) && Bitand(Int(m.pnlParam / 0x10000), 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* BYTE LOBYTE(
|
|
*!* Word wValue
|
|
*!* );
|
|
*!* Parameters
|
|
*!* wValue
|
|
*!* Specifies the Value To be converted.
|
|
*!* Return Value
|
|
*!* the Return Value Is the low-Order BYTE Of the specified Value.
|
|
********************************************************************************
|
|
Function ctlLoByte(m.pnlParam As Integer)
|
|
Return Bitand(m.pnlParam , 0xFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Word HIWORD(
|
|
*!* DWORD dwValue
|
|
*!* );
|
|
*!* Parameters
|
|
*!* dwValue
|
|
*!* Specifies the Value To be converted.
|
|
*!* Return Value
|
|
*!* the Return Value Is the High-Order Word Of the specified Value.
|
|
********************************************************************************
|
|
Function ctlHiWord(m.pnlParam As Integer)
|
|
Return Bitrshift(m.pnlParam, 16) && Bitand(Int(m.pnlParam / 0x10000), 0xFFFF)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Word LOWORD(
|
|
*!* DWORD dwValue
|
|
*!* );
|
|
*!* Parameters
|
|
*!* dwValue
|
|
*!* Specifies the Value To be converted.
|
|
*!* Return Value
|
|
*!* the Return Value Is the low-Order Word Of the specified Value.
|
|
********************************************************************************
|
|
Function ctlLoWord(m.pnlParam As Integer)
|
|
Return Bitand(m.pnlParam, 0xFFFF)
|
|
Endfunc
|
|
|
|
|
|
Function ctlGetStringResource(pcResource As String, pnStringId As Integer)
|
|
Local ;
|
|
lnModule As Integer, ;
|
|
llReleaseLibrary As Boolean, ;
|
|
lcString As String
|
|
|
|
*!* Get module handle of user32 if it is loaded
|
|
m.lnModule = apiGetModuleHandle(m.pcResource)
|
|
|
|
*!* If not loaded, load it
|
|
If m.lnModule = 0 Then
|
|
m.llReleaseLibrary = TRUE
|
|
m.lnModule = apiLoadLibrary(m.pcResource)
|
|
Else
|
|
m.llReleaseLibrary = FALSE
|
|
Endif
|
|
|
|
m.lcString = Replicate(NULA, 1024)
|
|
|
|
m.lnStringLen = apiLoadString(m.lnModule, m.pnStringId, @m.lcString, Len(m.lcString))
|
|
|
|
m.lcString = Left(m.lcString, m.lnStringLen)
|
|
|
|
If m.llReleaseLibrary = TRUE Then
|
|
apiFreeLibrary(m.lnModule)
|
|
Endif
|
|
|
|
Return m.lcString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* DWORD MAKELONG(
|
|
*!* Word wLow,
|
|
*!* Word wHigh
|
|
*!* );
|
|
*!* Parameters
|
|
*!* wLow
|
|
*!* Specifies the low-Order Word Of the new Value.
|
|
*!* wHigh
|
|
*!* Specifies the High-Order Word Of the new Value.
|
|
*!* Return Value
|
|
*!* the Return Value Is a Long Value.
|
|
********************************************************************************
|
|
Function ctlMakeLong(m.pnLow As Integer, m.pnHigh As Integer)
|
|
Return m.pnLow + m.pnHigh * 0x10000 && Bitor(m.wLow, BITLSHIFT(m.wHigh, 16)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* LPARAM MAKELPARAM(
|
|
*!* WORD wLow,
|
|
*!* WORD wHigh
|
|
*!* );
|
|
*!* Parameters
|
|
*!* wLow
|
|
*!* Specifies the low-order word of the new value.
|
|
*!* wHigh
|
|
*!* Specifies the high-order word of the new value.
|
|
*!* Return Value
|
|
*!* The return value is an LPARAM value.
|
|
********************************************************************************
|
|
Function ctlMakelParam(m.pnLow As Integer, m.pnHigh As Integer)
|
|
Return m.pnLow + m.pnHigh * 0x10000 && Bitor(m.wLow, BITLSHIFT(m.wHigh, 16)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* POINT
|
|
*!* The POINT structure defines the x- and y- coordinates of a point.
|
|
*!* typedef struct tagPOINT {
|
|
*!* LONG x;
|
|
*!* LONG y;
|
|
*!* } POINT, *PPOINT;
|
|
*!* Members
|
|
*!* x
|
|
*!* Specifies the x-coordinate of the point.
|
|
*!* y
|
|
*!* Specifies the y-coordinate of the point.
|
|
*!* This is not a Windows Macro
|
|
********************************************************************************
|
|
Function ctlMakePoint(m.pnX As Integer, m.pnY As Integer)
|
|
Return BinToC(m.pnX, "4RS") + BinToC(m.pnY, "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlMakewParam(m.pnLow As Integer, m.pnHigh As Integer)
|
|
********************************************************************************
|
|
Return ctlMakelParam(m.pnLow, m.pnHigh)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* POINT
|
|
*!* The POINT structure defines the x- and y- coordinates of a point.
|
|
*!* typedef struct tagPOINT {
|
|
*!* LONG x;
|
|
*!* LONG y;
|
|
*!* } POINT, *PPOINT;
|
|
*!* Members
|
|
*!* x
|
|
*!* Specifies the x-coordinate of the point.
|
|
*!* y
|
|
*!* Specifies the y-coordinate of the point.
|
|
*!* This is not a Windows Macro
|
|
********************************************************************************
|
|
Function ctlGetXFromPoint(m.pcPoint As String)
|
|
Return CToBin(Substr(m.pcPoint, 1, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* POINT
|
|
*!* The POINT structure defines the x- and y- coordinates of a point.
|
|
*!* typedef struct tagPOINT {
|
|
*!* LONG x;
|
|
*!* LONG y;
|
|
*!* } POINT, *PPOINT;
|
|
*!* Members
|
|
*!* x
|
|
*!* Specifies the x-coordinate of the point.
|
|
*!* y
|
|
*!* Specifies the y-coordinate of the point.
|
|
*!* This is not a Windows Macro
|
|
********************************************************************************
|
|
Function ctlGetYFromPoint(m.pcPoint As String)
|
|
Return CToBin(Substr(m.pcPoint, 5, 4), "4RS")
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* This returns an object reference to the parent form
|
|
*!* of a non top level form:
|
|
*!* the _Screen, or some Top Level Form
|
|
*!* accepts as parameter a form reference
|
|
********************************************************************************
|
|
Function ctlGetParentForm(m.poForm As Form)
|
|
Local ;
|
|
m.lnHwnd As Integer, ;
|
|
m.loForm As Form, ;
|
|
m.lnX As Integer
|
|
|
|
m.lnHwnd = apiGetParent(m.poForm.HWnd)
|
|
|
|
If _Screen.HWnd = m.lnHwnd Then
|
|
m.loForm = _Screen
|
|
Else
|
|
*!* Parent is a Top Level Form, get HWnd of form, what we have
|
|
*!* now is HWnd of inner window of Top Level Form:
|
|
m.lnHwnd = apiGetParent(m.lnHwnd)
|
|
|
|
*!* Find the Top Level Form that has this HWnd:
|
|
For m.lnX = 1 To _Screen.FormCount
|
|
If _Screen.Forms(m.lnX).HWnd = m.lnHwnd Then
|
|
m.loForm = _Screen.Forms(m.lnX)
|
|
Exit
|
|
Endif
|
|
Endfor
|
|
Endif
|
|
|
|
Return m.loForm
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns current date formated string
|
|
*!* 1 DATE_SHORTDATE
|
|
*!* 2 DATE_LONGDATE
|
|
********************************************************************************
|
|
Function ctlGetDateFormat(pnFlags As Integer)
|
|
|
|
Local ;
|
|
lnLocale As Integer, ;
|
|
lcDate As String, ;
|
|
lcFormat As String, ;
|
|
lcDateStr As String, ;
|
|
lnDateStrLen As Integer, ;
|
|
lnFlags As Integer
|
|
|
|
If Vartype(m.pnFlags) # T_NUMERIC Then
|
|
m.lnFlags = DATE_LONGDATE
|
|
Else
|
|
m.lnFlags = m.pnFlags
|
|
Endif
|
|
|
|
m.lnLocale = LOCALE_USER_DEFAULT
|
|
|
|
m.lcDate = .Null.
|
|
m.lcFormat = .Null.
|
|
|
|
m.lnDateStrLen = 0xFF
|
|
m.lcDateStr = Space(m.lnDateStrLen)
|
|
|
|
m.lnDateStrLen = apiGetDateFormat( ;
|
|
m.lnLocale, ;
|
|
m.lnFlags, ;
|
|
@m.lcDate, ;
|
|
@m.lcFormat, ;
|
|
@m.lcDateStr, ;
|
|
m.lnDateStrLen)
|
|
m.lcDateStr= Left(m.lcDateStr, m.lnDateStrLen - 1)
|
|
|
|
Return m.lcDateStr
|
|
Endfunc
|
|
|
|
Function ctlGetDateFormatEx(pdDate, pnLocale, pnFlags)
|
|
|
|
Local ;
|
|
lcDate As String, ;
|
|
lcFormat As String, ;
|
|
lcDateStr As String, ;
|
|
lnDateStrLen As Integer, ;
|
|
ldDate As Date, ;
|
|
lnLocale As Integer, ;
|
|
lnFlags As Integer
|
|
|
|
If Vartype(m.pdDate) # T_DATE Then
|
|
m.ldDate = Date()
|
|
Else
|
|
m.ldDate = m.pdDate
|
|
Endif
|
|
|
|
If Vartype(m.pnLocale) # T_NUMERIC Then
|
|
m.lnLocale = LOCALE_USER_DEFAULT
|
|
Else
|
|
m.lnLocale = m.pnLocale
|
|
Endif
|
|
|
|
If Vartype(m.pnFlags) # T_NUMERIC Then
|
|
m.lnFlags = DATE_LONGDATE
|
|
Else
|
|
m.lnFlags = m.pnFlags
|
|
Endif
|
|
|
|
*!* .http://msdn.microsoft.com/en-us/library/ms724950(VS.85).aspx
|
|
*!* typedef struct _SYSTEMTIME {
|
|
*!* WORD wYear;
|
|
*!* WORD wMonth;
|
|
*!* WORD wDayOfWeek;
|
|
*!* WORD wDay;
|
|
*!* WORD wHour;
|
|
*!* WORD wMinute;
|
|
*!* WORD wSecond;
|
|
*!* WORD wMilliseconds;
|
|
*!* *!* } SYSTEMTIME
|
|
|
|
m.lcDate = ;
|
|
BinToC(Year(m.ldDate), "2rs") + ;
|
|
BinToC(Month(m.ldDate), "2rs") + ;
|
|
BinToC(Dow(m.ldDate, 1), "2rs") + ;
|
|
BinToC(Day(m.ldDate), "2rs") + ;
|
|
0h0000 + ;
|
|
0h0000 + ;
|
|
0h0000 + ;
|
|
0h0000
|
|
|
|
m.lcFormat = .Null.
|
|
|
|
m.lnDateStrLen = 0xFF
|
|
m.lcDateStr = Space(m.lnDateStrLen)
|
|
|
|
m.lnDateStrLen = apiGetDateFormat( ;
|
|
m.lnLocale, ;
|
|
m.lnFlags, ;
|
|
m.lcDate, ;
|
|
m.lcFormat, ;
|
|
@m.lcDateStr, ;
|
|
m.lnDateStrLen)
|
|
|
|
m.lcDateStr= Left(m.lcDateStr, m.lnDateStrLen - 1)
|
|
|
|
Return m.lcDateStr
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns the type of container a control is in, or the type of form
|
|
*!* accepts as parameter a control or a form reference
|
|
|
|
*!* CON_FORMTYPE_DEFAULT 0
|
|
*!* CON_FORMTYPE_TOPLEVEL 1
|
|
*!* CON_FORMTYPE_SCREEN 2
|
|
|
|
*!* Determine the type of form the control parameter is in,
|
|
*!* or the type of form, if the passed parameter is a form
|
|
|
|
*!* Parameter can be a form, toolbar or control
|
|
********************************************************************************
|
|
Function ctlGetFormType(m.poObject As Object)
|
|
|
|
Local ;
|
|
m.loForm As Form, ;
|
|
m.lnFormType As Integer
|
|
|
|
m.loForm = m.poObject
|
|
|
|
*!* Go up the object hierarchy until we find a form:
|
|
*!* 20070711 Modified to account for toolbars
|
|
Do While Inlist(Upper(m.loForm.BaseClass), "FORM", "TOOLBAR") = FALSE
|
|
If Type("m.loForm.Parent") = T_OBJECT Then
|
|
m.loForm = m.loForm.Parent
|
|
Else
|
|
m.loForm = _Screen.ActiveForm
|
|
Exit
|
|
Endif
|
|
Enddo
|
|
|
|
m.lnFormType = CON_FORMTYPE_DEFAULT
|
|
|
|
*!* If container is a TLF, must have ShowWindow = 2
|
|
If m.loForm.ShowWindow = CON_SHOWWIN_ASTOPLEVELFORM Then
|
|
m.lnFormType = CON_FORMTYPE_TOPLEVEL
|
|
Endif
|
|
|
|
*!* If Form.Name equals the _Screen.Name, then container is _Screen
|
|
If m.loForm.Name == _Screen.Name Then
|
|
m.lnFormType = CON_FORMTYPE_SCREEN
|
|
Endif
|
|
|
|
m.loForm = Null
|
|
|
|
Return m.lnFormType
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlTwipsPerPixelX()
|
|
|
|
Local ;
|
|
m.lnDc As Integer, ;
|
|
m.lnLogPixelsX As Integer
|
|
|
|
m.lnDc = apiGetDC(HWND_DESKTOP)
|
|
m.lnLogPixelsX = apiGetDeviceCaps(m.lnDc, LOGPIXELSX)
|
|
apiReleaseDC(HWND_DESKTOP, m.lnDc)
|
|
Return Round(1440 / m.lnLogPixelsX, 0)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlTwipsPerPixelY()
|
|
|
|
Local ;
|
|
m.lnDc As Integer, ;
|
|
m.lnLogPixelsY As Integer
|
|
|
|
m.lnDc = apiGetDC(HWND_DESKTOP)
|
|
m.lnLogPixelsY = apiGetDeviceCaps(m.lnDc, LOGPIXELSY)
|
|
apiReleaseDC(HWND_DESKTOP, m.lnDc)
|
|
Return Round(1440 / m.lnLogPixelsY, 0)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* GUID FUNCTIONS
|
|
********************************************************************************
|
|
*!* http://www.ietf.org/rfc/rfc4122.txt
|
|
*!* http://en.wikipedia.org/wiki/Globally_Unique_Identifier
|
|
*!* http://en.wikipedia.org/wiki/Universally_Unique_Identifier
|
|
|
|
********************************************************************************
|
|
*!* Returns a new binary 16 byte GUID
|
|
|
|
*!* In Windows NT 4.0, Windows Me/98, and Windows 95 DCOM release, UuidCreate returns
|
|
*!* RPC_S_UUID_LOCAL_ONLY when the originating computer does not have an ethernet/token ring
|
|
*!* (IEEE 802.x) address. In this case, the generated UUID is a valid identifier, and is guaranteed
|
|
*!* to be unique among all UUIDs generated on the computer. However, the possibility exists that
|
|
*!* another computer without an ethernet/token ring address generated the identical UUID.
|
|
*!* Therefore you should never use this UUID to identify an object that is not strictly local to
|
|
*!* your computer. Computers with ethernet/token ring addresses generate UUIDs that are guaranteed
|
|
*!* to be globally unique.
|
|
********************************************************************************
|
|
Function ctlNewGuid()
|
|
|
|
Local m.lcGuid As String
|
|
|
|
m.lcGuid = Replicate(Chr(0xFF), 16)
|
|
apiUuidCreate(@m.lcGuid)
|
|
|
|
Return m.lcGuid
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlNewGuidNil()
|
|
|
|
Local m.lcGuid As String
|
|
|
|
m.lcGuid = Replicate(Chr(0xFF), 16)
|
|
apiUuidCreateNil(@m.lcGuid)
|
|
|
|
Return m.lcGuid
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
Function ctlNewGuidSequential()
|
|
|
|
Local m.lcGuid As String
|
|
|
|
m.lcGuid = Replicate(Chr(0xFF), 16)
|
|
apiUuidCreateSequential(@m.lcGuid)
|
|
|
|
Return m.lcGuid
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns a new 32 char GUID string
|
|
*!* Format "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
|
|
********************************************************************************
|
|
Function ctlNewGuidString32()
|
|
Return ctlGuidToString32(ctlNewGuid())
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns a new 36 char GUID string
|
|
*!* Format "XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX"
|
|
********************************************************************************
|
|
Function ctlNewGuidString36()
|
|
Return ctlGuidToString36(ctlNewGuid())
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Returns a new 38 char GUID string
|
|
*!* Format "{XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX}"
|
|
********************************************************************************
|
|
Function ctlNewGuidString38()
|
|
Return ctlGuidToString38(ctlNewGuid())
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts a binary 16 byte GUID to a 32 char GUID string
|
|
*!* format "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
|
|
********************************************************************************
|
|
Function ctlGuidToString32(pcGuid As String)
|
|
|
|
Local m.lcGuidString As String
|
|
|
|
m.lcGuidString = ""
|
|
|
|
*!* Reorder GUID bytes
|
|
m.lcGuidString = ;
|
|
Substr(m.pcGuid, 4, 1) + ;
|
|
Substr(m.pcGuid, 3, 1) + ;
|
|
Substr(m.pcGuid, 2, 1) + ;
|
|
Substr(m.pcGuid, 1, 1) + ;
|
|
Substr(m.pcGuid, 6, 1) + ;
|
|
Substr(m.pcGuid, 5, 1) + ;
|
|
Substr(m.pcGuid, 8, 1) + ;
|
|
Substr(m.pcGuid, 7, 1) + ;
|
|
Substr(m.pcGuid, 9, 8)
|
|
|
|
*!* Convert bytes to encoded HexBinary
|
|
m.lcGuidString = Strconv(m.lcGuidString, 15)
|
|
|
|
Return m.lcGuidString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts a binary 16 byte GUID to a 36 char GUID string
|
|
*!* format "XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX"
|
|
*!* This is faster that using the StringFromGuid2 API call
|
|
********************************************************************************
|
|
Function ctlGuidToString36(pcGuid As String)
|
|
|
|
Local ;
|
|
m.lcGuidString As String, ;
|
|
m.lcGuid As String
|
|
|
|
m.lcGuidString = ""
|
|
|
|
*!* Convert bytes to encoded HexBinary
|
|
m.lcGuid = Strconv(m.pcGuid, 15)
|
|
|
|
*!* Reorder GUID bytes, Add hyphens
|
|
m.lcGuidString = ;
|
|
Substr(m.lcGuid, 07, 02) + ;
|
|
Substr(m.lcGuid, 05, 02) + ;
|
|
Substr(m.lcGuid, 03, 02) + ;
|
|
Substr(m.lcGuid, 01, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 11, 02) + ;
|
|
Substr(m.lcGuid, 09, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 15, 02) + ;
|
|
Substr(m.lcGuid, 13, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 17, 04) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 21, 12)
|
|
|
|
Return m.lcGuidString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts a binary 16 byte GUID to a 38 char GUID string
|
|
*!* format "{XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX}"
|
|
*!* This is faster that using the StringFromGuid2 API call
|
|
********************************************************************************
|
|
Function ctlGuidToString38(pcGuid As String)
|
|
|
|
Local ;
|
|
m.lcGuidString As String, ;
|
|
m.lcGuid As String
|
|
|
|
m.lcGuidString = ""
|
|
|
|
*!* Convert bytes to encoded HexBinary
|
|
m.lcGuid = Strconv(m.pcGuid, 15)
|
|
|
|
*!* Reorder GUID bytes, Add brackets, hyphens
|
|
m.lcGuidString = ;
|
|
"{" + ;
|
|
Substr(m.lcGuid, 07, 02) + ;
|
|
Substr(m.lcGuid, 05, 02) + ;
|
|
Substr(m.lcGuid, 03, 02) + ;
|
|
Substr(m.lcGuid, 01, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 11, 02) + ;
|
|
Substr(m.lcGuid, 09, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 15, 02) + ;
|
|
Substr(m.lcGuid, 13, 02) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 17, 04) + ;
|
|
"-" + ;
|
|
Substr(m.lcGuid, 21, 12) + ;
|
|
"}"
|
|
|
|
Return m.lcGuidString
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Converts char GUID string to a binary 16 byte GUID
|
|
*!* format "{XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX}"
|
|
*!* format "XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX"
|
|
*!* format "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
|
|
********************************************************************************
|
|
Function ctlGuidFromString(pcGuidString As String)
|
|
|
|
Local ;
|
|
m.lcGuid As String, ;
|
|
m.lcGuidString As String
|
|
|
|
m.lcGuid = ""
|
|
|
|
*!* Strip brackets and hyphens
|
|
m.lcGuidString = Chrtran(m.pcGuidString, "{-}", "")
|
|
|
|
*!* Reorder GUID string chars
|
|
m.lcGuid = ;
|
|
+ Substr(m.lcGuidString, 7, 2) ;
|
|
+ Substr(m.lcGuidString, 5, 2) ;
|
|
+ Substr(m.lcGuidString, 3, 2) ;
|
|
+ Left(m.lcGuidString, 2) ;
|
|
+ Substr(m.lcGuidString, 11, 2) ;
|
|
+ Substr(m.lcGuidString, 9, 2) ;
|
|
+ Substr(m.lcGuidString, 15, 2) ;
|
|
+ Substr(m.lcGuidString, 13, 2) ;
|
|
+ Right(m.lcGuidString, 16)
|
|
|
|
*!* Convert bytes to decoded HexBinary
|
|
m.lcGuid = Strconv(m.lcGuid, 16)
|
|
|
|
Return m.lcGuid
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Used just to check the other functions
|
|
*!* StringUuid parameter of UuidToString:
|
|
*!* Pointer to a pointer to the string into which
|
|
*!* the UUID specified in the Uuid parameter will be placed.
|
|
*!* UuidToString returns a string in the following format:
|
|
*!* "xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxxx" (lowercase)
|
|
********************************************************************************
|
|
Function ctlGuidToStringApi1(m.pcGuid As String)
|
|
|
|
Local m.lnPointer As Integer
|
|
|
|
m.lnPointer = 0
|
|
apiUuidToString(m.pcGuid, @m.lnPointer)
|
|
|
|
Return Sys(2600, m.lnPointer, 36)
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Used just to check the other functions
|
|
********************************************************************************
|
|
Function ctlGuidToStringApi2(m.pcGuid As String)
|
|
|
|
Local ;
|
|
m.lcGuidString As String, ;
|
|
m.lcLen As Integer
|
|
|
|
*!* Set up buffer: 39 chars * 2 (unicode)
|
|
m.lcGuidString = Space(78)
|
|
m.lcLen = 78
|
|
|
|
apiStringFromGUID2(m.pcGuid, @m.lcGuidString, m.lcLen)
|
|
|
|
*!* Remove double null and convert from Unicode:
|
|
Return Strconv(Left(m.lcGuidString, 76), 6)
|
|
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* Used just to check the other functions
|
|
********************************************************************************
|
|
Function ctlGuidFromStringApi(m.pcGuidString As String)
|
|
|
|
Local ;
|
|
m.lcUuid As String, ;
|
|
m.lcGuidString As String
|
|
|
|
*!* Strip brackets and hyphens
|
|
m.lcGuidString = Chrtran(m.pcGuidString, "{-}", "")
|
|
|
|
*!* Add hyphens
|
|
m.lcGuidString = ;
|
|
LEFT(m.lcGuidString, 8) ;
|
|
+ "-" ;
|
|
+ Substr(m.lcGuidString, 9, 4) ;
|
|
+ "-" ;
|
|
+ Substr(m.lcGuidString, 13, 4) ;
|
|
+ "-" ;
|
|
+ Substr(m.lcGuidString, 17, 4) ;
|
|
+ "-" ;
|
|
+ Right(m.lcGuidString, 12)
|
|
|
|
m.lcUuid = Replicate(Chr(0xFF), 16)
|
|
apiUuidFromString(m.lcGuidString, @m.lcUuid)
|
|
Return m.lcUuid
|
|
|
|
Endfunc
|
|
|
|
********************************************************************************
|
|
*!* END ctl32_functions
|
|
********************************************************************************
|
|
|
|
|
|
Function __BaseX( txVal, tcDom )
|
|
* Converts a number to a string representation of that number
|
|
* tnVal - Number
|
|
* tcDom - The domain of characters to be used
|
|
* typical Domains are:
|
|
* "01" - Binary
|
|
* "0123456789" - Decimal
|
|
* "0123456789abcdef" - Hex
|
|
* "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" - Base62
|
|
* "23456789ABCDEFGHJKLMNPRSTUVWXYZ" - No {01IOQ} - they might confuse a user.
|
|
|
|
* If you want the result padded, use PADL()
|
|
|
|
Local ;
|
|
lnVal, ;
|
|
lnDomSiz, ;
|
|
lcRet, ;
|
|
lnPosition, ;
|
|
lnPlace
|
|
|
|
If Vartype(txVal) = "N"
|
|
If txVal < 0 Then
|
|
txVal = txVal + 1
|
|
Endif
|
|
lnVal = txVal
|
|
lnDomSiz = Len(tcDom)
|
|
|
|
* Humans get restless if the value zero is displayed as an empty string (blank).
|
|
* The first char of the domain (generally 0) is normally used as a place holder,
|
|
* but in the case of the value zero, it fills in to keep the peace.
|
|
* This may have lead to the fall of Rome.
|
|
|
|
If lnVal = 0
|
|
lcRet = Substr( tcDom, 1, 1 )
|
|
Else
|
|
lcRet = ''
|
|
Do While lnVal <> 0
|
|
lnDig = lnVal % lnDomSiz
|
|
lnVal = Int( lnVal/lnDomSiz )
|
|
If txVal > 0 Then
|
|
lcDig = Substr( tcDom, lnDig+1, 1 )
|
|
Else
|
|
If lnDig = 0 Then
|
|
lnDig = 16
|
|
Endif
|
|
lcDig = Substr( tcDom, lnDig, 1 )
|
|
Endif
|
|
|
|
lcRet = lcDig + lcRet
|
|
Enddo
|
|
Endif
|
|
lxRet=lcRet
|
|
Else
|
|
* Convert it back to decimal
|
|
lnVal = 0
|
|
lnPlace = 0
|
|
For lnPosition = Len(txVal) To 1 Step -1
|
|
lnVal = lnVal + (At( Substr(txVal,lnPosition,1), tcDom)-1) * (Len(tcDom)^lnPlace)
|
|
lnPlace=lnPlace+1
|
|
Endfor
|
|
lxRet = lnVal
|
|
Endif
|
|
|
|
Return lxRet
|
|
Endfunc
|