使用 Access 365。我想幫助構建代碼以實作以下目標，我正在嘗試簡化將影像添加到記錄的程序。
我想使用 VBA 在單擊按鈕時將影像保存為 .jpg 從剪貼板（用戶使用 Snip 工具放在那里）到資料庫的子檔案夾，然后將此檔案的相對鏈接傳遞給表單。我希望能夠以這種方式將多個影像的鏈接附加到給定記錄。
使用下面的代碼（沒有 AltPrintScreen 元素）我已經從剪貼板保存并生成絕對鏈接，但僅作為 .bmp。（https://www.access-programmers.co.uk/forums/threads/print-screen-into-image-file.245198/）。感謝任何幫助完成剩下的作業，或者提出一種完全不同的方法。干杯!
模塊...
'***********************************************************************************************
' *
' * Please leave any Trademarks or Credits in place.
' *
' * ACKNOWLEDGEMENT TO CONTRIBUTORS :
' * STEPHEN BULLEN, 15 November 1998 - Original PastPicture code
' * G HUDSON, 5 April 2010 - Pause Function
' * LUTZ GENTKOW, 23 July 2011 - Alt PrtScrn
' * PAUL FRANCIS, 11 April 2013 - Putting all pieces togeather
' *
' * DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
' * This object is then saved to a location on the disc. Please note, this
' * can also be assigned to (for example) and Image control on a userform.
' *
' * The code requires a reference to the "OLE Automation" type library.
' *
' * The code in this module has been derived from a number of sources
' * discovered on MSDN, Access World Forum, VBForums.
' *
' * To use it, just copy this module into your project, then you can use:
' * SaveClip2Bit("C:\Pics\Sample.bmp")
' * to save this to a location on the Disc.
' * (Or)
' * Set ImageControl.Image = PastePicture
' * to paste a picture of whatever is on the clipboard into a standard image control.
' *
' * PROCEDURES:
' * PastePicture : The entry point for 'Setting' the Image
' * CreatePicture : Private function to convert a bitmap or metafile handle to an OLE reference
' * fnOLEError : Get the error text for an OLE error code
' * SaveClip2Bit : The entry point for 'Saving' the Image, calls for PastePicture
' * AltPrintScreen: Performs the automation of Alt PrtScrn, for getting the Active Window.
' * Pause : Makes the program wait, to make sure proper screen capture takes place.
'**************************************************************************************************
Option Explicit
Option Compare Text
'Declare clipboard clear
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Windows API Function Declarations
#If Win64 = 1 And VBA7 = 1 Then
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
'Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
'Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
' Subroutine : AltPrintScreen
' Purpose : Capture the Active window, and places on the Clipboard.
Sub AltPrintScreen()
'keybd_event VK_MENU, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
'keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub
' Subroutine : PastePicture
' Purpose : Get a Picture object showing whatever's on the clipboard.
Function PastePicture() As IPicture
'Some pointers
Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Check if the clipboard contains the required format
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, CF_BITMAP)
End If
End If
End Function
' Subroutine : CreatePicture
' Purpose : Converts a image (and palette) handle into a Picture object.
' NOTE : Requires a reference to the "OLE Automation" type library
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = hPal ' Handle to palette (if bitmap).
End With
' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
' Return the new Picture object.
Set CreatePicture = IPic
End Function
' Subroutine : fnOLEError
' Purpose : Gets the message text for standard OLE errors
Private Function fnOLEError(lErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select
End Function
' Routine : SaveClip2Bit
' Purpose : Saves Picture object to desired location.
' Arguments : Path to save the file
Public Sub SaveClip2Bit(savePath As String)
On Error GoTo errHandler:
AltPrintScreen
Pause (2)
SavePicture PastePicture, savePath
errExit:
Exit Sub
errHandler:
Debug.Print "Save Picture: (" & Err.Number & ") - " & Err.Description
Resume errExit
End Sub
' Routine : Pause
' Purpose : Gives a short intreval for proper image capture.
' Arguments : Seconds to wait.
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause
Dim PauseTime As Variant, start As Variant
PauseTime = NumberOfSeconds
start = Timer
Do While Timer < start PauseTime
DoEvents
Loop
Exit_Pause:
Exit Function
Err_Pause:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
Resume Exit_Pause
End Function
uj5u.com熱心網友回復：
我創建了一個可以滿足我需求的解決方案。我使用了在各個站點上找到的四個模塊，然后創建了一些 VBA 來在后臺將任務整合在一起。
- 模塊 1 是我在上述問題中發布的模塊。我繞過了它的 AltPrintScreen 部分，因此它不會覆寫剪貼板中已經存在的影像。
- 模塊 2 將模塊 1 創建的 BMP 轉換為 JPG。
- 模塊 3 掃描檔案夾并使用在其中找到的檔案串列填充未系結的串列框。
- 模塊 4 用于使串列框中的檔案路徑充當超鏈接以在單擊時打開影像。
然后，我在呼叫前兩個模塊的表單上創建了一個按鈕，以從剪貼板中的影像創建 jpg，如下所示...
Private Sub Command12_Click()
Dim Foldername As String
Dim FileRoot As String
Dim FilePathBMP As String
Dim FilePathJPG As String
Dim FilePathJPG2 As String
' Fist check to see if a unique folder for the open record exists, create if not
Foldername = CurrentProject.Path & "\xrays\" & Format(record_id.Value)
If Len(Dir(Foldername, vbDirectory)) = 0 Then
MkDir CurrentProject.Path & "\xrays\" & Format(record_id.Value)
End If
On Error GoTo reportErr
'The filename will begin with a date\time stamp then pull text from drop down lists the user can pick. This first creates a base filename without filtype extensions.
FileRoot = CurrentProject.Path & "\xrays\" & Format(record_id.Value) & "\" & Format(Now, "yyyymmddhhmmss") & "_" & Format(Combo14.Value) & "_" & Format(Combo21.Value)
'Creates a BMP and JPG version of the filename
FilePathBMP = FileRoot & ".bmp"
FilePathJPG = FileRoot & ".jpg"
'Save a BMP
SaveClip2Bit FilePathBMP
'Convert to JPG
WIA_ConvertImage FilePathBMP, FilePathJPG, JPEG, 85
'Delete the BMP
Kill (FilePathBMP)
Exit Sub
reportErr:
MsgBox "No image in Clipboard"
Resume Next
End Sub
在將顯示檔案串列的表單上，我放置了一個未系結的串列框“FileList”。以下代碼呼叫模塊 3，并在表單的 onl oad 事件中...
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
以下代碼用于重繪 串列框“FileList”。可以放在按鈕的OnClick事件上，也可以放在上面代碼的最后，添加新圖片后自動重繪
Me.FileList.RowSource = ""
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
Me.FileList.Requery
最后我把下面的代碼放在串列框的 OnDblClick 事件中，它呼叫了模塊 4...
Dim sPath As String
Dim sFile As String
sPath = FileList.Column(0)
' The line below extracts the filename from the full path (everything to the right of the last /)
' sFile = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
GoHyperlink (sPath)
模塊 2...
Public Enum wiaFormat
BMP = 0
GIF = 1
JPEG = 2
PNG = 3
TIFF = 4
End Enum
'---------------------------------------------------------------------------------------
' Procedure : WIA_ConvertImage
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Convert an image's format using WIA
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Windows Image Acquisition (WIA)
' https://msdn.microsoft.com/en-us/library/windows/desktop/ms630368(v=vs.85).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInitialImage : Fully qualified path and filename of the original image to resize
' sOutputImage : Fully qualified path and filename of where to save the new image
' lFormat : Format to convert the image into
' lQuality : Quality level to be used for the conversion process (1-100)
'
' Usage:
' ~~~~~~
' Call WIA_ConvertImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
' "C:\Users\MyUser\Desktop\Chrysanthemum_2.jpg", _
' JPEG)
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2017-01-18 Initial Release
' 2 2018-09-20 Updated Copyright
'---------------------------------------------------------------------------------------
Public Function WIA_ConvertImage(sInitialImage As String, _
sOutputImage As String, _
lFormat As wiaFormat, _
Optional lQuality As Long = 85) As Boolean
On Error GoTo Error_Handler
Dim oWIA As Object 'WIA.ImageFile
Dim oIP As Object 'ImageProcess
Dim sFormatID As String
Dim sExt As String
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
If lQuality > 100 Then lQuality = 100
'Should check if the output file already exists and if so,
'prompt the user to overwrite it or not
Set oWIA = CreateObject("WIA.ImageFile")
Set oIP = CreateObject("WIA.ImageProcess")
oIP.Filters.Add oIP.FilterInfos("Convert").FilterID
oIP.Filters(1).Properties("FormatID") = sFormatID
oIP.Filters(1).Properties("Quality") = lQuality
oWIA.LoadFile sInitialImage
Set oWIA = oIP.Apply(oWIA)
'Overide the specified ext with the appropriate one for the choosen format
oWIA.SaveFile Left(sOutputImage, InStrRev(sOutputImage, ".")) & LCase(sExt)
WIA_ConvertImage = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oWIA Is Nothing Then Set oWIA = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_ConvertImage" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
模塊 3...
Option Compare Database
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
' The list box must have its Row Source Type property set to Value List.
'Method: FilDir() adds items to a collection, calling itself recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList
Debug.Print varItem
Next
Else
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
模塊 4...
Option Compare Database
Option Explicit
'Purpose: Avoid warning and error messages when opening files with FollowHyperlink
'Author: Allen Browne ([email protected])
'Release: 28 January 2008
'Usage: To open MyFile.doc in Word, use:
' GoHyperlink "MyFile.doc"
' instead of:
' FollowHyperlink "MyFile.doc"
'Rationale:
'FollowHyperlink has several problems:
' a) It errors if a file name contains characters such as #, %, or &.
' b) It can give unwanted warnings, e.g. on a fileame with "file:///" prefix.
' c) It yields errors if the link did not open.
'This replacement:
' a) escapes the problem characters
' b) prepends the prefix
' c) returns True if the link opened (with an optional error message if you care.)
'Limitations:
' - If a file name contains two # characters, it is treated as a hyperlink.
' - If a file name contains % followed by 2 hex digits, it assumes it is pre-escaped.
' - File name must include path.
'Documentation: http://allenbrowne.com/func-GoHyperlink.html
Public Function GoHyperlink(FullFilenameOrLink As Variant) As Boolean
On Error GoTo Err_Handler
'Purpose: Replacement for FollowHyperlink.
'Return: True if the hyperlink opened.
'Argument: varIn = the link to open
Dim strLink As String
Dim strErrMsg As String
'Skip error, null, or zero-length string.
If Not IsError(FullFilenameOrLink) Then
If FullFilenameOrLink <> vbNullString Then
strLink = PrepHyperlink(FullFilenameOrLink, strErrMsg)
If strLink <> vbNullString Then
FollowHyperlink strLink
'Return True if we got here without error.
GoHyperlink = True
End If
'Display any error message from preparing the link.
If strErrMsg <> vbNullString Then
MsgBox strErrMsg, vbExclamation, "PrepHyperlink()"
End If
End If
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "GoHyperlink()"
Resume Exit_Handler
End Function
Public Function PrepHyperlink(varIn As Variant, Optional strErrMsg As String) As Variant
On Error GoTo Err_Handler
'Purpose: Avoid errors and warnings when opening hyperlinks.
'Return: The massaged link/file name.
'Arguments: varIn = the link/file name to massage.
' strErrMsg = string to append error messages to.
'Note: Called by GoHyperlink() above.
' Can also be called directly, to prepare hyperlinks.
Dim strAddress As String 'File name or address
Dim strDisplay As String 'Display part of hyperlink (if provided)
Dim strTail As String 'Any remainding part of hyperlink after address
Dim lngPos1 As Long 'Position of character in string (and next)
Dim lngPos2 As Long
Dim bIsHyperlink As Boolean 'Flag if input is a hyperlink (not just a file name.)
Const strcDelimiter = "#" 'Delimiter character within hyperlinks.
Const strcEscChar = "%" 'Escape character for hyperlinks.
Const strcPrefix As String = "file:///" 'Hyperlink type if not supplied.
If Not IsError(varIn) Then
strAddress = Nz(varIn, vbNullString)
End If
If strAddress <> vbNullString Then
'Treat as a hyperlink if there are two or more # characters (other than together, or at the end.)
lngPos1 = InStr(strAddress, strcDelimiter)
If (lngPos1 > 0&) And (lngPos1 < Len(strAddress) - 2&) Then
lngPos2 = InStr(lngPos1 1&, strAddress, strcDelimiter)
End If
If lngPos2 > lngPos1 1& Then
bIsHyperlink = True
strTail = Mid$(strAddress, lngPos2 1&)
strDisplay = Left$(strAddress, lngPos1 - 1&)
strAddress = Mid$(strAddress, lngPos1 1&, lngPos2 - lngPos1)
End If
'Replace any % that is not immediately followed by 2 hex digits (in both display and address.)
strAddress = EscChar(strAddress, strcEscChar)
strDisplay = EscChar(strDisplay, strcEscChar)
'Replace special characters with percent sign and hex value (address only.)
strAddress = EscHex(strAddress, strcEscChar, "&", """", " ", "#", "<", ">", "|", "*", "?")
'Replace backslash with forward slash (address only.)
strAddress = Replace(strAddress, "\", "/")
'Add prefix if address doesn't have one.
If Not ((varIn Like "*://*") Or (varIn Like "mailto:*")) Then
strAddress = strcPrefix & strAddress
End If
End If
'Assign return value.
If strAddress <> vbNullString Then
If bIsHyperlink Then
PrepHyperlink = strDisplay & strcDelimiter & strAddress & strcDelimiter & strTail
Else
PrepHyperlink = strAddress
End If
Else
PrepHyperlink = Null
End If
Exit_Handler:
Exit Function
Err_Handler:
strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
Resume Exit_Handler
End Function
Private Function EscChar(ByVal strIn As String, strEscChar As String) As String
'Purpose: If the escape character is found in the string,
' escape it (unless it is followed by 2 hex digits.)
'Return: Fixed up string.
'Arguments: strIn = the string to fix up
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
Dim strOut As String 'output string.
Dim strChar As String 'character being considered.
Dim strTestHex As String '4-character string of the form &HFF.
Dim lngLen As Long 'Length of input string.
Dim i As Long 'Loop controller
Dim bReplace As Boolean 'Flag to replace character.
lngLen = Len(strIn)
If (lngLen > 0&) And (Len(strEscChar) = 1&) Then
For i = 1& To lngLen
bReplace = False
strChar = Mid(strIn, i, 1&)
If strChar = strEscChar Then
strTestHex = "&H" & Mid(strIn, i 1&, 2&)
If Len(strTestHex) = 4& Then
If Not IsNumeric(strTestHex) Then
bReplace = True
End If
End If
End If
If bReplace Then
strOut = strOut & strEscChar & Hex(Asc(strEscChar))
Else
strOut = strOut & strChar
End If
Next
End If
If strOut <> vbNullString Then
EscChar = strOut
ElseIf lngLen > 0& Then
EscChar = strIn
End If
End Function
Private Function EscHex(ByVal strIn As String, strEscChar As String, ParamArray varChars()) As String
'Purpose: Replace any characters from the array with the escape character and their hex value.
'Return: Fixed up string.
'Arguments: strIn = string to fix up.
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
' varChars() = an array of single-character strings to replace.
Dim i As Long 'Loop controller
If (strIn <> vbNullString) And IsArray(varChars) Then
For i = LBound(varChars) To UBound(varChars)
strIn = Replace(strIn, varChars(i), strEscChar & Hex(Asc(varChars(i))))
Next
End If
EscHex = strIn
End Function
我希望所有這些都對其他人有所幫助！
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/443341.html
上一篇：根據表單上另一個欄位值的結果自定義MSAccess表單欄位查找
下一篇：實作各種進制轉換(c++版)