?? common.bas
字號(hào):
Open gstrSilentLog For Append As fn
Print #fn, strMsg
Close fn
Exit Sub
End Sub
'-----------------------------------------------------------
' FUNCTION: LogSMSMsg
'
' If this is a SMS install, this routine appends
' a message to the gstrSMSDescription string. This
' string will later be written to the SMS status
' file (*.MIF) when the installation completes (success
' or failure).
'
' Note that if gfSMS = False, not message will be logged.
' Therefore, to prevent some messages from being logged
' (e.g., confirmation only messages), temporarily set
' gfSMS = False.
'
' IN: [strMsg] - The message
'
' Normally, this routine is called inlieu of displaying
' a MsgBox and strMsg is the same message that would
' have appeared in the MsgBox
'-----------------------------------------------------------
'
Sub LogSMSMsg(strMsg As String)
If Not gfSMS Then Exit Sub
'
' Append the message. Note that the total
' length cannot be more than 255 characters, so
' truncate anything after that.
'
gstrSMSDescription = Left(gstrSMSDescription & strMsg, MAX_SMS_DESCRIP)
End Sub
'-----------------------------------------------------------
' FUNCTION: MakePathAux
'
' Creates the specified directory path.
'
' No user interaction occurs if an error is encountered.
' If user interaction is desired, use the related
' MakePathAux() function.
'
' IN: [strDirName] - name of the dir path to make
'
' Returns: True if successful, False if error.
'-----------------------------------------------------------
'
Function MakePathAux(ByVal strDirName As String) As Boolean
Dim strPath As String
Dim intOffset As Integer
Dim intAnchor As Integer
Dim strOldPath As String
On Error Resume Next
'
'Add trailing backslash
'
If Right$(strDirName, 1) <> gstrSEP_DIR Then
strDirName = strDirName & gstrSEP_DIR
End If
strOldPath = CurDir$
MakePathAux = False
intAnchor = 0
'
'Loop and make each subdir of the path separately.
'
intOffset = InStr(intAnchor + 1, strDirName, gstrSEP_DIR)
intAnchor = intOffset 'Start with at least one backslash, i.e. "C:\FirstDir"
Do
intOffset = InStr(intAnchor + 1, strDirName, gstrSEP_DIR)
intAnchor = intOffset
If intAnchor > 0 Then
strPath = Left$(strDirName, intOffset - 1)
' Determine if this directory already exists
Err = 0
ChDir strPath
If Err Then
' We must create this directory
Err = 0
#If LOGGING Then
NewAction gstrKEY_CREATEDIR, """" & strPath & """"
#End If
MkDir strPath
#If LOGGING Then
If Err Then
LogError ResolveResString(resMAKEDIR) & " " & strPath
AbortAction
GoTo Done
Else
CommitAction
End If
#End If
End If
End If
Loop Until intAnchor = 0
MakePathAux = True
Done:
ChDir strOldPath
Err = 0
End Function
'-----------------------------------------------------------
' FUNCTION: MsgError
'
' Forces mouse pointer to default, calls VB's MsgBox
' function, and logs this error and (32-bit only)
' writes the message and the user's response to the
' logfile (32-bit only)
'
' IN: [strMsg] - message to display
' [intFlags] - MsgBox function type flags
' [strCaption] - caption to use for message box
' [intLogType] (optional) - The type of logfile entry to make.
' By default, creates an error entry. Use
' the MsgWarning() function to create a warning.
' Valid types as MSGERR_ERROR and MSGERR_WARNING
'
' Returns: Result of MsgBox function
'-----------------------------------------------------------
'
Function MsgError(ByVal strMsg As String, ByVal intFlags As Integer, ByVal strCaption As String, Optional ByVal intLogType As Integer = MSGERR_ERROR) As Integer
Dim iRet As Integer
iRet = MsgFunc(strMsg, intFlags, strCaption)
MsgError = iRet
#If LOGGING Then
' We need to log this error and decode the user's response.
Dim strID As String
Dim strLogMsg As String
Select Case iRet
Case vbOK
strID = ResolveResString(resLOG_vbok)
Case vbCancel
strID = ResolveResString(resLOG_vbCancel)
Case vbAbort
strID = ResolveResString(resLOG_vbabort)
Case vbRetry
strID = ResolveResString(resLOG_vbretry)
Case vbIgnore
strID = ResolveResString(resLOG_vbignore)
Case vbYes
strID = ResolveResString(resLOG_vbyes)
Case vbNo
strID = ResolveResString(resLOG_vbno)
Case Else
strID = ResolveResString(resLOG_IDUNKNOWN)
'End Case
End Select
strLogMsg = strMsg & vbLf & "(" & ResolveResString(resLOG_USERRESPONDEDWITH, "|1", strID) & ")"
On Error Resume Next
Select Case intLogType
Case MSGERR_WARNING
LogWarning strLogMsg
Case MSGERR_ERROR
LogError strLogMsg
Case Else
LogError strLogMsg
'End Case
End Select
#End If
End Function
'-----------------------------------------------------------
' FUNCTION: MsgFunc
'
' Forces mouse pointer to default and calls VB's MsgBox
' function. See also MsgError.
'
' IN: [strMsg] - message to display
' [intFlags] - MsgBox function type flags
' [strCaption] - caption to use for message box
' Returns: Result of MsgBox function
'-----------------------------------------------------------
'
Function MsgFunc(ByVal strMsg As String, ByVal intFlags As Integer, ByVal strCaption As String) As Integer
Dim intOldPointer As Integer
intOldPointer = Screen.MousePointer
If gfNoUserInput Then
MsgFunc = GetDefMsgBoxButton(intFlags)
If gfSilent = True Then
LogSilentMsg strMsg
End If
If gfSMS = True Then
LogSMSMsg strMsg
gfDontLogSMS = False
End If
Else
Screen.MousePointer = gintMOUSE_DEFAULT
MsgFunc = MsgBox(strMsg, intFlags, strCaption)
Screen.MousePointer = intOldPointer
End If
End Function
'-----------------------------------------------------------
' FUNCTION: MsgWarning
'
' Forces mouse pointer to default, calls VB's MsgBox
' function, and logs this error and (32-bit only)
' writes the message and the user's response to the
' logfile (32-bit only)
'
' IN: [strMsg] - message to display
' [intFlags] - MsgBox function type flags
' [strCaption] - caption to use for message box
'
' Returns: Result of MsgBox function
'-----------------------------------------------------------
'
Function MsgWarning(ByVal strMsg As String, ByVal intFlags As Integer, ByVal strCaption As String) As Integer
MsgWarning = MsgError(strMsg, intFlags, strCaption, MSGERR_WARNING)
End Function
'-----------------------------------------------------------
' SUB: SetFormFont
'
' Walks through all controls on specified form and
' sets Font a font chosen according to the system locale
'
' IN: [frm] - Form whose control fonts need to be set.
'-----------------------------------------------------------
'
Public Sub SetFormFont(frm As Form)
Dim ctl As Control
Dim fntSize As Integer
Dim fntName As String
Dim fntCharset As Integer
Dim oFont As StdFont
' some controls may fail, so we will do a resume next...
'
On Error Resume Next
' get the font name, size, and charset
'
GetFontInfo fntName, fntSize, fntCharset
'Create a new font object
Set oFont = New StdFont
With oFont
.Name = fntName
.Size = fntSize
.Charset = fntCharset
End With
' Set the form's font
Set frm.Font = oFont
'
' loop through each control and try to set its font property
' this may fail, but our error handling is shut off
'
For Each ctl In frm.Controls
Set ctl.Font = oFont
Next
'
' get out, reset error handling
'
Set ctl = Nothing
On Error GoTo 0
Exit Sub
End Sub
'-----------------------------------------------------------
' SUB: GetFontInfo
'
' Gets the best font to use according the current system's
' locale.
'
' OUT: [sFont] - name of font
' [nFont] - size of font
' [nCharset] - character set of font to use
'-----------------------------------------------------------
Private Sub GetFontInfo(sFont As String, nFont As Integer, nCharSet As Integer)
Dim LCID As Integer
Dim PLangId As Integer
Dim sLangId As Integer
' if font is set, used the cached values
If m_sFont <> "" Then
sFont = m_sFont
nFont = m_nFont
nCharSet = m_nCharset
Exit Sub
End If
' font hasn't been set yet, need to get it now...
LCID = GetSystemDefaultLCID ' get current system LCID
PLangId = PRIMARYLANGID(LCID) ' get LCID's Primary language id
sLangId = SUBLANGID(LCID) ' get LCID's Sub language id
Select Case PLangId ' determine primary language id
Case LANG_CHINESE
If (sLangId = SUBLANG_CHINESE_TRADITIONAL) Then
sFont = ChrW$(&H65B0) & ChrW$(&H7D30) & ChrW$(&H660E) & ChrW$(&H9AD4) ' New Ming-Li
nFont = 9
nCharSet = CHARSET_CHINESEBIG5
ElseIf (sLangId = SUBLANG_CHINESE_SIMPLIFIED) Then
sFont = ChrW$(&H5B8B) & ChrW$(&H4F53)
nFont = 9
nCharSet = CHARSET_CHINESESIMPLIFIED
End If
Case LANG_JAPANESE
sFont = ChrW$(&HFF2D) & ChrW$(&HFF33) & ChrW$(&H20) & ChrW$(&HFF30) & _
ChrW$(&H30B4) & ChrW$(&H30B7) & ChrW$(&H30C3) & ChrW$(&H30AF)
nFont = 9
nCharSet = CHARSET_SHIFTJIS
Case LANG_KOREAN
If (sLangId = SUBLANG_KOREAN) Then
sFont = ChrW$(&HAD74) & ChrW$(&HB9BC)
ElseIf (sLangId = SUBLANG_KOREAN_JOHAB) Then
sFont = ChrW$(&HAD74) & ChrW$(&HB9BC)
End If
nFont = 9
nCharSet = CHARSET_HANGEUL
Case Else
sFont = "Tahoma"
If Not IsFontSupported(sFont) Then
'Tahoma is not on this machine. This condition is very probably since
'this is a setup program that may be run on a clean machine
'Try Arial
sFont = "Arial"
If Not IsFontSupported(sFont) Then
'Arial isn't even on the machine. This is an unusual situation that
'is caused by deliberate removal
'Try system
sFont = "System"
'If system isn't supported, allow the default font to be used
If Not IsFontSupported(sFont) Then
'If "System" is not supported, "IsFontSupported" will have
'output the default font in sFont
End If
End If
End If
nFont = 8
' set the charset for the users default system Locale
nCharSet = GetUserCharset
End Select
m_sFont = sFont
m_nFont = nFont
m_nCharset = nCharSet
'-------------------------------------------------------
End Sub
'-------------------------------------------------------
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號(hào)
Ctrl + =
減小字號(hào)
Ctrl + -