• 0

[VB6] Retrieving CD Track# From Embedded WMP Control


Question

Hi

I hope someone here will be able to help me...I've got a WMP control embedded into an app created in the old VB6. I'd like to be able to retrieve the track number of the song playing from an Audio CD in my application.

I've looked on the SDK Documenation, but this is one thing i cannot find. I cant find any attribute that i can read from to retrieve the track number.

Thanks in advance, i know someone in here will be able to help

Link to comment
Share on other sites

1 answer to this question

Recommended Posts

  • 0

don't use WMP control - use this API call:

throw below text into a code module:

Option Explicit
Public lPrevProc As Long

Private Const MCI_OPEN = &H803
Private Const MCI_CLOSE = &H804
Private Const MCI_WAIT = &H2&
Private Const MCI_OPEN_ELEMENT = &H200&
Private Const MCI_OPEN_ALIAS = &H400&
Private Const MCI_OPEN_TYPE = &H2000&
Private Const MCI_OPEN_TYPE_ID = &H1000&
Private Const MCI_OPEN_SHAREABLE = &H100&

Private Const MCI_NOTIFY = &H1&
Private Const MCI_NOTIFY_SUCCESSFUL = &H1
Private Const MCI_NOTIFY_SUPERSEDED = &H2
Private Const MCI_NOTIFY_ABORTED = &H4
Private Const MCI_NOTIFY_FAILURE = &H8
Private Const MM_MCINOTIFY = &H3B9

Private Const MCI_PLAY = &H806
Private Const MCI_PAUSE = &H809
Private Const MCI_RESUME = &H855
Private Const MCI_STOP = &H808
Private Const MCI_TO = &H8
Private Const MCI_FROM = &H4

Private Const MCI_SEEK = &H807
Private Const MCI_SEEK_TO_END = &H200&
Private Const MCI_SEEK_TO_START = &H100&

Private Const MCI_SET = &H80D
Private Const MCI_FORMAT_MSF = 2
Private Const MCI_FORMAT_TMSF = 10
Private Const MCI_SET_TIME_FORMAT = &H400&

Private Const MCI_STATUS = &H814
Private Const MCI_STATUS_ITEM = &H100&
Private Const MCI_STATUS_LENGTH = &H1&
Private Const MCI_STATUS_NUMBER_OF_TRACKS = &H3&
Private Const MCI_STATUS_CURRENT_TRACK = &H8&

Private Const MCI_CDA_STATUS_TYPE_TRACK = &H4001&
Private Const MCI_CD_OFFSET = 1088
Public Const MCI_CDA_TRACK_AUDIO = (MCI_CD_OFFSET)
Public Const MCI_CDA_TRACK_OTHER = (MCI_CD_OFFSET + 1)

Private Const MCI_STATUS_POSITION = &H2&
Private Const MCI_STATUS_MODE = &H4&
Private Const MCI_TRACK = &H10&

Private Const MCI_SET_DOOR_OPEN = &H100&
Private Const MCI_SET_DOOR_CLOSED = &H200&

Private Const MCI_INFO = &H80A
Private Const MCI_INFO_MEDIA_UPC = &H400&
Private Const MCI_INFO_MEDIA_IDENTITY = &H800&

Private Const MCI_STRING_OFFSET = 512
Public Const MCI_MODE_NOT_READY = (MCI_STRING_OFFSET + 12)
Public Const MCI_MODE_OPEN = (MCI_STRING_OFFSET + 18)
Public Const MCI_MODE_PAUSE = (MCI_STRING_OFFSET + 17)
Public Const MCI_MODE_PLAY = (MCI_STRING_OFFSET + 14)
Public Const MCI_MODE_RECORD = (MCI_STRING_OFFSET + 15)
Public Const MCI_MODE_SEEK = (MCI_STRING_OFFSET + 16)
Public Const MCI_MODE_STOP = (MCI_STRING_OFFSET + 13)

Private Type MCI_OPEN_PARMS
	dwCallback As Long
	wDeviceID As Long
	lpstrDeviceType As String
	lpstrElementName As String
	lpstrAlias As String
End Type

Private Type MCI_SET_PARMS
	dwCallback As Long
	dwTimeFormat As Long
	dwAudio As Long
End Type

Private Type MCI_STATUS_PARMS
	dwCallback As Long
	dwReturn As Long
	dwItem As Long
	dwTrack As Integer
End Type

Private Type MCI_INFO_PARMS
	dwCallback As Long
	lpstrReturn As String
	dwRetSize As Long
End Type

Private Type MCI_PLAY_PARMS
   dwCallback As Long
   dwFrom As Long
   dwTo As Long
End Type

Public Type MCI_GENERIC_PARMS
	dwCallback As Long
End Type

Private Type MCI_SEEK_PARMS
   dwCallback As Long
   dwTo As Long
End Type

Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByRef dwParam2 As Any) As Long
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long

Private mciOpenParms As MCI_OPEN_PARMS
Private mciSetParms As MCI_SET_PARMS
Private mciStatusParms As MCI_STATUS_PARMS
Private mciInfoParams As MCI_INFO_PARMS
Private mciPlayParms As MCI_PLAY_PARMS
Private mciGenericParms As MCI_GENERIC_PARMS
Private mciSeekParms As MCI_SEEK_PARMS

Private Function DecodeError(ByVal errCode As Long)
	On Local Error Resume Next
	Dim sts As Long
	Dim errBuf As String * 256

	sts = mciGetErrorString(errCode, errBuf, 256)
	Debug.Print errBuf
End Function

Public Function OpenCD(ByVal strDrive As String) As Long
	On Local Error Resume Next
	Dim Idx As Integer
	Dim sts As Long

	On Error GoTo errChk

	mciOpenParms.lpstrDeviceType = "cdaudio"
	mciOpenParms.lpstrElementName = strDrive & ":"
	mciOpenParms.lpstrAlias = "CD_" & strDrive & ":"
	sts = mciSendCommand(0, MCI_OPEN, MCI_OPEN_ELEMENT Or MCI_OPEN_SHAREABLE Or MCI_OPEN_ALIAS Or MCI_OPEN_TYPE Or MCI_WAIT, mciOpenParms)
	If (sts <> 0) Then GoTo errChk

	OpenCD = mciOpenParms.wDeviceID
	Exit Function

errChk:
	DecodeError (sts)
	OpenCD = False
End Function

Public Sub CloseCD(ByVal m_DevID As Long)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long
	sts = mciSendCommand(m_DevID, MCI_CLOSE, MCI_NOTIFY, 0)
	m_DevID = 0
End Sub

Public Function GetDiscTOC(ByVal m_DevID As Long) As String
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim mciStatusParms As MCI_STATUS_PARMS
	Dim Idx As Integer, trks As Integer
	Dim mins As Long, secs As Long, frms As Long
	Dim sts As Long, offst As Long, s As String

	On Error GoTo errChk

	mciSetParms.dwTimeFormat = MCI_FORMAT_MSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	trks = mciStatusParms.dwReturn

	For Idx = 1 To trks
		mciStatusParms.dwItem = MCI_STATUS_POSITION
		mciStatusParms.dwTrack = Idx
		sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, mciStatusParms)
		If (sts <> 0) Then GoTo errChk

		mins = (mciStatusParms.dwReturn) And &HFF
		secs = (mciStatusParms.dwReturn \ 256) And &HFF
		frms = (mciStatusParms.dwReturn \ 65536) And &HFF

		offst = (mins * 60 * 75) + (secs * 75) + frms
		s = s & " " & Format$(offst)
	Next Idx

	GetDiscTOC = Trim$(s)
	Exit Function
errChk:
	DecodeError (sts)
	GetDiscTOC = ""
End Function

Public Function DriveDoorOpen(ByVal m_DevID As Long) As Boolean
	On Local Error Resume Next
	Dim sts As Long
	On Error GoTo errChk
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_DOOR_OPEN, 0&)
	If (sts <> 0) Then GoTo errChk
	DriveDoorOpen = True
	Exit Function
errChk:
	DecodeError (sts)
	DriveDoorOpen = False
End Function

Public Function DriveDoorClose(ByVal m_DevID As Long) As Boolean
	On Local Error Resume Next
	Dim sts As Long
	On Error GoTo errChk
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_DOOR_CLOSED, 0&)
	If (sts <> 0) Then GoTo errChk
	DriveDoorClose = True
	Exit Function
errChk:
	DecodeError (sts)
	DriveDoorClose = False
End Function

Public Function GetTrackLEN(ByVal m_DevID As Long, ByVal lTrack As Integer) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_LENGTH
	mciStatusParms.dwTrack = lTrack
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_TRACK Or MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetTrackLEN = mciStatusParms.dwReturn
	Exit Function
errChk:
	DecodeError (sts)
	GetTrackLEN = 0
End Function

Public Function GetTrackSeconds(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_POSITION
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	Dim lTemp As Long
	lTemp = mciStatusParms.dwReturn
	lTemp = (MCI_TMSF_MINUTE(lTemp) * 60) + MCI_TMSF_SECOND(lTemp)
	GetTrackSeconds = lTemp
	Exit Function
errChk:
	GetTrackSeconds = 0
	DecodeError (sts)
End Function

Public Function GetDiscLEN(ByVal m_DevID As Long) As String
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim mciStatusParms As MCI_STATUS_PARMS
	Dim Idx As Integer, trks As Integer
	Dim mins As Long, secs As Long, frms As Long
	Dim sts As Long, offst As Long, s As String

	On Error GoTo errChk

	mciSetParms.dwTimeFormat = MCI_FORMAT_MSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	trks = mciStatusParms.dwReturn

	For Idx = 1 To trks
		mciStatusParms.dwItem = MCI_STATUS_POSITION
		mciStatusParms.dwTrack = Idx
		sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, mciStatusParms)
		If (sts <> 0) Then GoTo errChk

		mins = (mciStatusParms.dwReturn) And &HFF
		secs = (mciStatusParms.dwReturn \ 256) And &HFF
		frms = (mciStatusParms.dwReturn \ 65536) And &HFF

		offst = (mins * 60 * 75) + (secs * 75) + frms
		s = s & " " & Format$(offst)
	Next Idx

	mciStatusParms.dwItem = MCI_STATUS_LENGTH
	mciStatusParms.dwTrack = trks
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, mciStatusParms)
	If (sts <> 0) Then GoTo errChk

	mins = (mciStatusParms.dwReturn) And &HFF
	secs = (mciStatusParms.dwReturn \ 256) And &HFF
	frms = ((mciStatusParms.dwReturn \ 65536) And &HFF) + 1

	offst = offst + (mins * 60 * 75) + (secs * 75) + frms
	s = Format$(offst)

	GetDiscLEN = Trim$(s)
	Exit Function
errChk:
	DecodeError (sts)
	GetDiscLEN = ""
End Function

Public Function GetDiscSerial(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long
	On Error GoTo errChk
	mciInfoParams.dwCallback = 0
	mciInfoParams.dwRetSize = 32
	mciInfoParams.lpstrReturn = Space(mciInfoParams.dwRetSize)
	sts = mciSendCommand(m_DevID, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, mciInfoParams)
	If (sts <> 0) Then GoTo errChk
	GetDiscSerial = CLng(mciInfoParams.lpstrReturn)
	Exit Function
errChk:
	DecodeError (sts)
	GetDiscSerial = 0
End Function

Public Function GetDiscUPC(ByVal m_DevID As Long) As String
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long
	On Error GoTo errChk
	mciInfoParams.dwCallback = 0
	mciInfoParams.dwRetSize = 32
	mciInfoParams.lpstrReturn = Space(mciInfoParams.dwRetSize)
	sts = mciSendCommand(m_DevID, MCI_INFO, MCI_INFO_MEDIA_UPC, mciInfoParams)
	If (sts <> 0) Then GoTo errChk
	GetDiscUPC = mciInfoParams.lpstrReturn
	Exit Function
errChk:
	DecodeError (sts)
	GetDiscUPC = 0
End Function

Public Function GetTrackType(ByVal m_DevID As Long, ByVal lTrack As Integer) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_CDA_STATUS_TYPE_TRACK
	mciStatusParms.dwTrack = lTrack
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_TRACK Or MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetTrackType = mciStatusParms.dwReturn
	Exit Function
errChk:
	DecodeError (sts)
	GetTrackType = 0
End Function

Public Function GetDiscCount(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetDiscCount = mciStatusParms.dwReturn
	Exit Function
errChk:
	DecodeError (sts)
	GetDiscCount = 0
End Function

Public Sub DiscPlay(ByVal m_DevID As Long, ByVal lTrack As Integer)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciPlayParms.dwCallback = frmMain.hwnd
	mciPlayParms.dwFrom = MCI_MAKE_TMSF(lTrack, 0, 0)
	mciPlayParms.dwTo = MCI_MAKE_TMSF(lTrack, MCI_TMSF_TRACK(GetTrackLEN(m_DevID, lTrack)), MCI_TMSF_MINUTE(GetTrackLEN(m_DevID, lTrack)))
	sts = mciSendCommand(m_DevID, MCI_PLAY, MCI_NOTIFY Or MCI_FROM Or MCI_TO, mciPlayParms)
	If (sts <> 0) Then GoTo errChk
	Exit Sub
errChk:
	DecodeError (sts)
End Sub

Public Sub DiscResume(ByVal m_DevID As Long)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long
	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	Dim lTrack As Integer
	lTrack = GetDiscTrack(m_DevID)

	mciPlayParms.dwCallback = frmMain.hwnd
	mciPlayParms.dwTo = MCI_MAKE_TMSF(lTrack, MCI_TMSF_TRACK(GetTrackLEN(m_DevID, lTrack)), MCI_TMSF_MINUTE(GetTrackLEN(m_DevID, lTrack)))
	sts = mciSendCommand(m_DevID, MCI_PLAY, MCI_NOTIFY Or MCI_TO, mciPlayParms)
	If (sts <> 0) Then GoTo errChk

	Exit Sub
errChk:
	DecodeError (sts)
End Sub

Public Sub DiscPause(ByVal m_DevID As Long)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long
	sts = mciSendCommand(m_DevID, MCI_PAUSE, MCI_NOTIFY, mciGenericParms)
	If (sts <> 0) Then GoTo errChk
	Exit Sub
errChk:
	DecodeError (sts)
End Sub

Public Sub DiscStop(ByVal m_DevID As Long)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long
	sts = mciSendCommand(m_DevID, MCI_STOP, MCI_NOTIFY, mciGenericParms)
	If (sts <> 0) Then GoTo errChk
	'SetDiscPosition (m_DevID)
	Exit Sub
errChk:
	DecodeError (sts)
End Sub

Public Function GetDiscTrack(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_POSITION
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetDiscTrack = MCI_TMSF_TRACK(mciStatusParms.dwReturn)
	Exit Function
errChk:
	GetDiscTrack = 0
	DecodeError (sts)
End Function

Public Function GetDiscPosition(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	mciStatusParms.dwItem = MCI_STATUS_POSITION
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetDiscPosition = mciStatusParms.dwReturn
	Exit Function
errChk:
	GetDiscPosition = 0
	DecodeError (sts)
End Function

Public Sub SetDiscPosition(ByVal m_DevID As Long)
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Sub
	Dim sts As Long

	mciSetParms.dwTimeFormat = MCI_FORMAT_TMSF
	sts = mciSendCommand(m_DevID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
	If (sts <> 0) Then GoTo errChk

	sts = mciSendCommand(m_DevID, MCI_SEEK, MCI_SEEK_TO_START, mciSeekParms)
	If (sts <> 0) Then GoTo errChk
	Exit Sub
errChk:
	DecodeError (sts)
End Sub

Public Function GetDiscMode(ByVal m_DevID As Long) As Long
	On Local Error Resume Next
	If m_DevID = 0 Then Exit Function
	Dim sts As Long

	mciStatusParms.dwItem = MCI_STATUS_MODE
	sts = mciSendCommand(m_DevID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
	If (sts <> 0) Then GoTo errChk
	GetDiscMode = mciStatusParms.dwReturn
	Exit Function
errChk:
	GetDiscMode = 0
	DecodeError (sts)
End Function

Public Function MCI_MAKE_TMSF(intTrack As Integer, intMinute As Integer, intSecond As Integer) As Long
	On Local Error Resume Next
	MCI_MAKE_TMSF = CLng(intTrack) Or CLng(Shli(intMinute, 8)) Or CLng(Shll(intSecond, 16))
End Function

Public Function MCI_TMSF_MINUTE(lngTime As Long) As Byte
	On Local Error Resume Next
	MCI_TMSF_MINUTE = IntToByte(Shri(LongToInt(lngTime), 8))
End Function

Public Function MCI_TMSF_SECOND(lngTime As Long) As Byte
	On Local Error Resume Next
	MCI_TMSF_SECOND = IntToByte(LongToInt(Shrl(lngTime, 16)))
End Function

Public Function MCI_TMSF_TRACK(lngTime As Long) As Byte
	On Local Error Resume Next
	MCI_TMSF_TRACK = IntToByte(LongToInt(lngTime))
End Function

Private Function Shli(ByVal intValue As Integer, ByVal bytPlaces As Byte) As Integer
	On Local Error Resume Next
	Dim lngMultiplier As Long
	If bytPlaces >= 16 Then
		Shli = 0
	Else
		lngMultiplier = 2 ^ bytPlaces
		Shli = LongToInt(intValue * lngMultiplier)
	End If
End Function

Private Function Shll(ByVal lngNumber As Long, ByVal bytPlaces As Byte) As Long
	On Local Error Resume Next
	Dim dblMultiplier As Double
	If bytPlaces >= 32 Then
		Shll = 0
	Else
		dblMultiplier = 2 ^ bytPlaces
		Shll = dblToLong(lngNumber * dblMultiplier)
	End If
End Function

Private Function Shri(ByVal lngValue As Long, ByVal bytPlaces As Byte) As Integer
	On Local Error Resume Next
	Dim lngDivisor As Long
	If bytPlaces >= 16 Then
		Shri = 0
	Else
		lngDivisor = 2 ^ bytPlaces
		Shri = Int(IntToLong(lngValue) / lngDivisor)
	End If
End Function

Private Function Shrl(ByVal lngNumber As Long, ByVal bytPlaces As Byte) As Long
	On Local Error Resume Next
	Dim lngDivisor As Long
	If bytPlaces >= 32 Then
		Shrl = 0
	Else
		lngDivisor = 2 ^ bytPlaces
		Shrl = Int(LongToDbl(lngNumber) / lngDivisor)
	End If
End Function

Private Function IntToByte(ByVal intNumber As Integer) As Byte
	On Local Error Resume Next
	IntToByte = intNumber And &HFF&
End Function

Private Function IntToLong(ByVal intNumber As Integer) As Long
	On Local Error Resume Next
	If intNumber < 0 Then
		IntToLong = intNumber + &H10000
	Else
		IntToLong = intNumber
	End If
End Function

Private Function LongToDbl(ByVal lngNumber As Long) As Double
	On Local Error Resume Next
	Dim dblDivisor As Double
	dblDivisor = &H7FFFFFFF
	dblDivisor = (dblDivisor * 2) + 2
	If lngNumber < 0 Then
		LongToDbl = lngNumber + dblDivisor
	Else
		LongToDbl = lngNumber
	End If
End Function

Private Function LongToInt(ByVal lngNumber As Long) As Integer
	On Local Error Resume Next
	lngNumber = lngNumber And &HFFFF&
	If lngNumber > &H7FFF Then
		LongToInt = lngNumber - &H10000
	Else
		LongToInt = lngNumber
	End If
End Function

Private Function dblToLong(ByVal dblNumber As Double) As Long
	On Local Error Resume Next
	Dim dblDivisor As Double
	Dim dblTemp As Double

	dblDivisor = &H7FFFFFFF
	dblDivisor = (dblDivisor * 2) + 2
	If dblNumber > dblDivisor Or dblNumber < 0 Then
		dblTemp = dblNumber - (Int(dblNumber / dblDivisor) * dblDivisor)
	Else
		dblTemp = dblNumber
	End If
	If dblTemp > &H7FFFFFFF Then
		dblToLong = dblTemp - dblDivisor
	ElseIf dblTemp < 0 Then
		dblToLong = dblDivisor + dblTemp
	Else
		dblToLong = dblTemp
	End If
End Function

need further help - pm me...

Link to comment
Share on other sites

This topic is now closed to further replies.
  • Recently Browsing   0 members

    • No registered users viewing this page.