! 發展單位：風禹科技驗證有限公司
! 撰寫人：鄭子璉(Tzu-Lien, Cheng, 璉璉) ，成大水博肄，微軟最有價值專家
! Web: http://tlcheng.twbbs.org/TLCheng/ E-Mail: qvb3377@ms5.hinet.net
! --------------------------------------------------------------------------------------

Module winVariant
	use kernel32
	Use oleaut32
	use ifwinty
	!Use ifcom

	Integer, Private, Parameter :: winVariant_ChangeType = 32
Contains
	! 從 ifcom.f90 內複製 ************************************
	INTEGER*4 FUNCTION ConvertStringToBSTR(string)
		USE OLEAUT32	
		USE IFNLS
		CHARACTER*(*), INTENT(IN)			  :: string
		INTEGER*4 bstr
		INTEGER*4 length
		INTEGER*2, ALLOCATABLE :: unistr(:)
		! First call to MBConvertMBToUnicode determines the length to allocate
		ALLOCATE (unistr(0))
		length = MBConvertMBToUnicode(string, unistr)
		DEALLOCATE (unistr)
		! Special case for all spaces
		IF (length < 0) THEN
			ALLOCATE (unistr(2))
			unistr(1) = #20	! Single space
			unistr(2) = 0		! Null terminate
		ELSE
			! Second call to MBConvertMBToUnicode does the conversion
			ALLOCATE (unistr(length+1))
			length = MBConvertMBToUnicode(string, unistr)
			unistr(length+1) = 0		! Null terminate
		END IF
		bstr = SysAllocString(unistr)
		DEALLOCATE (unistr)
		ConvertStringToBSTR = bstr
	END FUNCTION ConvertStringToBSTR
	INTEGER*4 FUNCTION ConvertBSTRToString(bstr, string)
      USE OLEAUT32	
		USE IFNLS
		INTEGER*4, INTENT(IN)				  :: bstr
	   CHARACTER*(*), INTENT(OUT)		  :: string
		INTEGER*4 length
		length = SysStringLen(bstr)
		ConvertBSTRToString = Convert(bstr, length, string)
		CONTAINS
		INTEGER*4 FUNCTION Convert(bstr, length, string)
			INTEGER*4, INTENT(IN)					  :: bstr
			INTEGER*4, INTENT(IN)					  :: length
			CHARACTER*(*), INTENT(OUT)			  :: string
			INTEGER*2 :: unistr(length)
			POINTER(p, unistr)
			p = bstr
			Convert = MBConvertUnicodeToMB(unistr, string)
		END FUNCTION Convert
	END FUNCTION ConvertBSTRToString
	! 從 ifcom.f90 內複製 ************************************

	Logical Function IsDateTime(strDateTime)
		Character*(*) :: strDateTime
		Type (Variant) :: vBSTR, vDate		
		Integer*4 :: status, pStr
		
		Call VariantInit(vBSTR)
		Call VariantInit(vDate)
		
		vBSTR%VT = VT_BSTR
		pStr = ConvertStringToBSTR(strDateTime)
		vBSTR%VU%PTR_VAL = pStr
		
		status = VariantChangeTypeEx(vDate, vBSTR, VT_BSTR, VARIANT_NOUSEROVERRIDE, VT_DATE)
		 
		If (status == S_OK) Then
			IsDateTime = .True.
		Else
			IsDateTime = .False.
		End If
		status = VariantClear(vBSTR)
		status = VariantClear(vDate)
		pStr = 0

	End Function

	Real*8 Function MyGetDateTime(strDateTime)
		Character*(*) :: strDateTime
		Type (Variant) :: vBSTR, vDate		
		Integer*4 :: status, pStr
		
		Call VariantInit(vBSTR)
		Call VariantInit(vDate)
		
		vBSTR%VT = VT_BSTR
		pStr = ConvertStringToBSTR(strDateTime)
		vBSTR%VU%PTR_VAL = pStr
		
		status = VariantChangeTypeEx(vDate, vBSTR, VT_BSTR, VARIANT_NOUSEROVERRIDE, VT_DATE)
		 
		If (status == S_OK) Then
			MyGetDateTime = vDate%VU%DOUBLE_VAL
			status = VariantClear(vDate)
		Else
			MyGetDateTime = 0.
		End If
		status = VariantClear(vBSTR)
		pStr = 0

	End Function

	Character*(winVariant_ChangeType) Function MyVariantToString(vVariant)
		Type (Variant) :: vVariant, vBSTR
		Integer*4 :: status, length
		Character*(winVariant_ChangeType) :: strVariant
		
		strVariant = Repeat(' ', winVariant_ChangeType)
		
		Call VariantInit(vBSTR)				
		status = VariantChangeTypeEx(vBSTR, vVariant, VT_BSTR, VARIANT_NOUSEROVERRIDE, VT_BSTR)
		 
		If (status == S_OK) Then
			length = ConvertBSTRToString(vBSTR%VU%PTR_VAL, strVariant)
			MyVariantToString = Trim(strVariant)			
		Else
			MyVariantToString = ''
		End If
		status = VariantClear(vBSTR)
		length = 0

	End Function
	
	Integer Function MyVariantToInteger(vVariant)
		Type (Variant) :: vVariant, vInteger
		Integer*4 :: status
		
		Call VariantInit(vInteger)				
		status = VariantChangeTypeEx(vInteger, vVariant, VT_BSTR, VARIANT_NOUSEROVERRIDE, VT_I4)
		 
		If (status == S_OK) Then
			MyVariantToInteger = vInteger%VU%LONG_VAL
		Else
			MyVariantToInteger = 0
		End If
		status = VariantClear(vInteger)

	End Function

	Type(Variant) Function MyFormat(vVariant, strFormat)
		! ms-help://MS.VSCC.2003/MS.MSDNQTR.2003FEB.1028/oledb/htm/olappr_chapter25_19.htm
		INTERFACE		
			INTEGER(4) FUNCTION VarFormat(pvarIn, pbstrFormat, iFirstDay, iFirstWeek, dwFlags, pbstrOut)
				!DEC$ ATTRIBUTES STDCALL :: VarFormat
				use ifwinty
				TYPE(VARIANT)         :: pvarIn
				INTEGER*4           :: pbstrFormat
				INTEGER*2           :: iFirstDay
				INTEGER*2          :: iFirstWeek
				INTEGER*4           :: dwFlags
				INTEGER*4         :: pbstrOut
				!DEC$ ATTRIBUTES REFERENCE          :: pbstrOut
			END FUNCTION 
		END INTERFACE
		Type (Variant) :: vVariant, vBSTR
		Integer(4) :: status, length, pStr, poStr
		Character*(winVariant_ChangeType) :: strVariant, tmpVariant
		Character*(*) :: strFormat
		Integer(4) :: pDLL, pVarFormat
		Pointer (pVarFormat, VarFormat)
		
		pDLL = loadlibrary('oleaut32.dll'C)
		pVarFormat = getprocaddress(pDLL, 'VarFormat'C)

		strVariant = Repeat(' ', winVariant_ChangeType)
		tmpVariant = Repeat(' ', winVariant_ChangeType)
		
		Call VariantInit(vBSTR)
		Call VariantInit(MyFormat)
		vBSTR%VT = VT_BSTR
		pStr = ConvertStringToBSTR(strFormat)
		vBSTR%VU%PTR_VAL = ConvertStringToBSTR(tmpVariant)
		
		status = VarFormat(vVariant, pStr, 0, 0, VAR_FORMAT_NOSUBSTITUTE, vBSTR%VU%PTR_VAL)
		
		If (status == S_OK) Then
			MyFormat = vBSTR
		Else
		End If
		 
		status = VariantClear(vBSTR)
		status = freelibrary(pDLL)

	End Function

	Character*(winVariant_ChangeType) Function MyFormatDate(dDate, strFormat)
		Real*8 :: dDate
		Type (Variant) :: vDate
		Integer*4 :: status
		Character*(*) :: strFormat
		
		Call VariantInit(vDate)
		vDate%VT = VT_DATE
		vDate%VU%DOUBLE_VAL = dDate
		
		MyFormatDate = MyVariantToString(MyFormat(vDate, strFormat))
		 
		status = VariantClear(vDate)
	End Function
	
	Integer Function MyFormatDateInteger(dDate, strFormat)
		Real*8 :: dDate
		Type (Variant) :: vDate
		Integer*4 :: status
		Character*(*) :: strFormat
		
		Call VariantInit(vDate)
		vDate%VT = VT_DATE
		vDate%VU%DOUBLE_VAL = dDate
		
		MyFormatDateInteger = MyVariantToInteger(MyFormat(vDate, strFormat))
		 
		status = VariantClear(vDate)
	End Function
	
	Integer Function MyGetYear(dDate)
		Real*8 :: dDate
		MyGetYear = MyFormatDateInteger(dDate, 'yyyy')
	End Function
	
	Integer Function MyGetMonth(dDate)
		Real*8 :: dDate
		MyGetMonth = MyFormatDateInteger(dDate, 'm')
	End Function

	Integer Function MyGetDay(dDate)
		Real*8 :: dDate
		MyGetDay = MyFormatDateInteger(dDate, 'd')
	End Function

	Integer Function MyGetDayOfYear(dDate)
		Real*8 :: dDate
		MyGetDayOfYear = MyFormatDateInteger(dDate, 'y')
	End Function

	Integer Function MyGetWeekDay(dDate)
		Real*8 :: dDate
		MyGetWeekDay = MyFormatDateInteger(dDate, 'w')
	End Function

	Real*8 Function MyGetDate(dDate)
		Real*8 :: dDate
		MyGetDate = Dble(Int(dDate))
	End Function

	Real*8 Function MyGetTime(dDate)
		Real*8 :: dDate
		MyGetTime = dDate - Dble(Int(dDate))
	End Function

	Integer Function MyGetHour(dDate)
		Real*8 :: dDate
		MyGetHour = Int(MyGetTime(dDate) * 24.)
	End Function

	Integer Function MyGetMinute(dDate)
		Real*8 :: dDate, dTime
		dTime = MyGetTime(dDate) * 24.
		MyGetMinute = Int((dTime - Dble(Int(dTime))) * 60.)
	End Function

	Integer Function MyGetSecond(dDate)
		Real*8 :: dDate, dTime
		dTime = MyGetTime(dDate) * 24. * 60.
		MyGetSecond = Int((dTime - Dble(Int(dTime))) * 60.)
	End Function

	Integer Function MyGetMilliSecond(dDate)
		Real*8 :: dDate, dTime
		dTime = MyGetTime(dDate) * 24. * 60. * 60.
		MyGetMilliSecond = Int((dTime - Dble(Int(dTime))) * 1000.)
	End Function

	Type(Variant) Function mySystemTimeToVariantTime(lpSystemTime)		
		INTERFACE		
			INTEGER(4) FUNCTION SystemTimeToVariantTime(lpSystemTime, pvtime)
				!DEC$ ATTRIBUTES STDCALL :: SystemTimeToVariantTime
				use ifwinty
				Type(t_SystemTime)         :: lpSystemTime
				Real*8         :: pvtime
				!DEC$ ATTRIBUTES REFERENCE          :: pvtime
			END FUNCTION 
		END INTERFACE
		Type (Variant) :: vDate
		Integer(4) :: status
		Type(t_SystemTime) :: lpSystemTime
		Integer(4) :: pDLL, pVarFormat
		Pointer (pSystemTimeToVariantTime, SystemTimeToVariantTime)
		
		pDLL = LoadLibrary('oleaut32.dll'C)
		pSystemTimeToVariantTime = GetProcAddress(pDLL, 'SystemTimeToVariantTime'C)

		Call VariantInit(vDate)
		Call VariantInit(mySystemTimeToVariantTime)
		
		status = SystemTimeToVariantTime(lpSystemTime, vDate%VU%DOUBLE_VAL)
		
		mySystemTimeToVariantTime = vDate
		 
		status = VariantClear(vDate)
		status = FreeLibrary(pDLL)

	End Function

	Real(8) Function MyGetUtcNow()
		Type(t_SystemTime) :: lpSystemTime
		Type (Variant) :: vDate
		
		Call GetSystemTime(lpSystemTime)
		vDate = mySystemTimeToVariantTime(lpSystemTime)
		MyGetUtcNow = vDate%VU%DOUBLE_VAL
	End Function

	Real(8) Function MyGetNow()
		Type(t_SystemTime) :: lpSystemTime
		Type (Variant) :: vDate
		
		Call GetLocalTime(lpSystemTime)
		vDate = mySystemTimeToVariantTime(lpSystemTime)
		MyGetNow = vDate%VU%DOUBLE_VAL
	End Function
End Module