PtrSafe

办公室终于换新电脑了,我那08年的老机器终于退役了……大哭

好吧,新机器8G内存,果断上64位系统

运行之前写的vba小程序,嗯?!提示要增加PtrSafe,去查了一圈,原来是这么回事儿啊

https://msdn.microsoft.com/zh-cn/library/gg278832.aspx

PtrSafe <keyword>

Office 2013

Last modified: December 06, 2011

Applies to: Office 2013 | VBA

The PtrSafe keyword is used in this context:

Declare Statement

Note Note

Declare statements with the PtrSafe keyword is the recommended syntax. Declare statements that include PtrSafe work correctly in the VBA7 development environment on both 32-bit and 64-bit platforms only after all data types in the Declarestatement (parameters and return values) that need to store 64-bit quantities are updated to use LongLong for 64-bit integrals or LongPtr for pointers and handles. To ensure backwards compatibility with VBA version 6 and earlier use the following construct:

VBA
#If Vba7 Then 
Declare PtrSafe Sub... 
#Else 
Declare Sub... 
#EndIf

When running in 64-bit versions of Office Declare statements must include the PtrSafe keyword.

The PtrSafe keyword asserts that a Declare statement is safe to run in 64-bit development environments.

Adding the PtrSafe keyword to a Declare statement only signifies the Declare statement explicitly targets 64-bits, all data types within the statement that need to store 64-bits (including return values and parameters) must still be modified to hold 64-bit quantities using either LongLong for 64-bit integrals or LongPtr for pointers and handles.


PtrSafe <keyword>

Office 2013

上次修改时间: 2011年12月6日

适用范围: Office 2013 | VBA

将"PtrSafe"关键字用于以下上下文:

Declare 语句

注释 注释

含"PtrSafe"关键字的 Declare 语句是推荐的语法。包含"PtrSafe"的 Declare 语句在 32 位和 64 位的平台上的 VBA7 开发环境中正常工作,只是要在需要存储 64 位数量的"Declare"语句(参数和返回值)中的所有数据类型被更新以将 LongLong 用于 64 位整数,或将LongPtr 用于指针和句柄。为了确保 VBA 版本 6 和更早版本的向后兼容性,请使用以下构造:

VBA
#If Vba7 Then 
Declare PtrSafe Sub... 
#Else 
Declare Sub... 
#EndIf

当在 Office 的 64 位版本中运行时,"Declare"语句必须包括"PtrSafe"关键字。

"PtrSafe"关键字断定"Declare"语句在 64 位的开发环境中运行是安全的。

将"PtrSafe"关键字添加到"Declare"语句只表明了"Declare"明确地以 64 位为目标,必须修改该语句中的所有需要存储 64 位的数据类型(包括返回值和参数)以通过将 LongLong 用于 64 位整数或将 LongPtr 用于指针和句柄来保留 64 位数量。



代码修正:Option Explicit Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function EmptyClipboard Lib32" () As Long Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Const CF_BITMAP = 2 Private Const SRCCOPY = &HCC0020
07-25
Option Explicit Public Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _ ByVal CodePage As Long, _ ByVal dwFlags As Long, _ ByRef lpMultiByteStr As Any, _ ByVal cchMultiByte As Long, _ ByVal lpWideCharStr As Long, _ ByVal cchWideChar As Long) As Long Public Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _ ByVal CodePage As Long, _ ByVal dwFlags As Long, _ ByVal lpWideCharStr As Long, _ ByVal cchWideChar As Long, _ ByRef lpMultiByteStr As Any, _ ByVal cchMultiByte As Long, _ ByVal lpDefaultChar As String, _ ByVal lpUsedDefaultChar As Long) As Long Public Const CP_UTF8 = 65001 ' ���A�����{�ʐiUTF8�i���I���{���� ' �A�� ' strInput�F���{������ ' strFile�F�ۑ��IUTF8�i�������H�a ' bBOM�FTrue�\��������"EFBBBF"���CFalse�\���s�� Public Function WriteUTF8File(strInput As String, strFile As String, Optional bBOM As Boolean = True) As Boolean Dim bByte As Byte Dim ReturnByte() As Byte Dim lngBufferSize As Long Dim lngResult As Long Dim TLen As Long ' ���f�A�����������ۈ׋� If Len(strInput) = 0 Then Exit Function On Error GoTo errHandle ' ���f�������ۑ��݁C�@���ݑ��폜 If Dir(strFile) <> "" Then Kill strFile TLen = Len(strInput) lngBufferSize = TLen * 3 + 1 ReDim ReturnByte(lngBufferSize - 1) lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strInput), TLen, _ ReturnByte(0), lngBufferSize, vbNullString, 0) If lngResult Then lngResult = lngResult - 1 ReDim Preserve ReturnByte(lngResult) Open strFile For Binary As #1 If bBOM = True Then bByte = 239 Put #1, , bByte bByte = 187 Put #1, , bByte bByte = 191 Put #1, , bByte End If Put #1, , ReturnByte Close #1 End If WriteUTF8File = True Exit Function errHandle: WriteUTF8File = False MsgBox Err.Description, , "���� - " & Err.Number End Functions这段Excel代码实行到Public Function WriteUTF8File(strInput As String, strFile As String, Optional bBOM As Boolean = True) As Boolean的时候报编译错误,类型不匹配
04-01
Option Explicit ' 声明Windows API函数 Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long) Private WithEvents Timer1 As MSForms.Timer Private wsh As Object Private objWnd As Object Private LastSwitchTime As Date ' 记录上次切换时间 Private Sub Form_Load() On Error Resume Next Set wsh = CreateObject("WScript.Shell") ' 创建提示窗口 Set objWnd = wsh.Exec("mshta.exe ""about:<title>运行中</title><body bgcolor=white><center><h1>运行中</h1><p>自动打开网页并切换标签页<br>每分钟自动切换标签页<br>关闭此窗口停止程序</p></center><script>window.resizeTo(800,400);window.moveTo((screen.width-800)/2,(screen.height-400)/2);</script>""") If Err.Number <> 0 Then MsgBox "提示窗口创建失败: " & Err.Description Exit Sub End If ' 初始化定时器 Set Timer1 = New MSForms.Timer Timer1.Interval = 1000 ' 1秒检测一次 Timer1.Enabled = True ' 打开浏览器窗口 OpenBrowserUrls End Sub Private Sub OpenBrowserUrls() Dim browserPath As String Dim urls(1 To 4) As String ' 4个URL browserPath = GetEdgePath() ' 动态获取Edge路径 ' 简化的URL(实际使用时替换为完整URL) urls(1) = "http://192.168.10.81/decision/view/form?viewlet=..." ' 当日出勤 urls(2) = "http://192.168.154.11:4000/gridWebAndon/revoAssembly_Allparts" ' #12线装配安东 urls(3) = "http://192.168.10.81/decision/view/form?viewlet=..." ' 人员管理板 urls(4) = "http://192.168.154.11:5000/gridWebAndon/revoAllparts" ' #12线加工安东 Dim i As Integer For i = 1 To 4 ' 打开浏览器窗口 wsh.Run Chr(34) & browserPath & Chr(34) & " " & Chr(34) & urls(i) & Chr(34) DoEvents ' 等待页面加载 Sleep 2000 ' 确保窗口激活后再发送F11 ActivateEdgeWindow Sleep 500 ' 短暂延迟确保激活完成 wsh.SendKeys "{F11}" Next i ' 额外确保最后一个窗口全屏 ActivateEdgeWindow Sleep 500 wsh.SendKeys "{F11}" LastSwitchTime = Now ' 初始化切换时间 End Sub ' 动态获取Edge浏览器路径 Private Function GetEdgePath() As String On Error Resume Next ' 尝试从注册表获取Edge路径 GetEdgePath = wsh.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\msedge.exe\") If Err.Number <> 0 Or GetEdgePath = "" Then ' 如果注册表获取失败,尝试备用路径 GetEdgePath = "C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe" End If End Function ' 激活Edge窗口 Private Sub ActivateEdgeWindow() Dim maxAttempts As Integer maxAttempts = 5 Do While maxAttempts > 0 On Error Resume Next wsh.AppActivate "Microsoft Edge" If Err.Number = 0 Then Exit Do Sleep 1000 maxAttempts = maxAttempts - 1 Loop End Sub Private Sub Timer1_Timer() ' 每1分钟切换一次标签页 If DateDiff("s", LastSwitchTime, Now) >= 60 Then ActivateEdgeWindow Sleep 500 ' 确保窗口激活 wsh.SendKeys "^{TAB}" ' Ctrl+Tab切换标签页 LastSwitchTime = Now End If End Sub ' 自定义Sleep函数(毫秒) Private Sub Sleep(ms As Long) Dim endTime As Date endTime = DateAdd("s", ms / 1000, Now) Do While Now < endTime DoEvents Loop End Sub ' 窗体卸载时清理资源 Private Sub Form_Unload(Cancel As Integer) If Not objWnd Is Nothing Then If objWnd.Status = 0 Then objWnd.Terminate End If Set Timer1 = Nothing Set wsh = Nothing End Sub 语句未结束
最新发布
08-09
这段代码的目的是调节系统音量或者静音。其中,PostMessage 函数用于向指窗口发送消息,第一个参数是目标口的句柄,第二个参数是消息类型,第三个参数是 wParam,第四个参数是 lParam。具体参数含义可以参考 Windows API 文档。 这段代码的问题在于,它使用了旧版的 API 函数声明方式,而在 64 位 Windows 上编译时需要使用 PtrSafe 关键字。所以,我们需要修改函数声明: Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr 同时,由于系统音量调节的实现方式可能因操作系统版本而异,所以建议使用更为稳定的 Windows API 函数来实现该功能。下面是一个修改后的代码示例: Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExW" (ByVal hWndParent As LongPtr, ByVal hWndChildAfter As LongPtr, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hWnd As LongPtr, ByVal lpClassName As LongPtr, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextW" (ByVal hWnd As LongPtr, ByVal lpWindowText As LongPtr, ByVal nMaxCount As Long) As Long Private Const WM_APPCOMMAND As Long = &H319 Private Const APPCOMMAND_VOLUME_UP As Long = &HA Private Const APPCOMMAND_VOLUME_DOWN As Long = &H9 Private Const APPCOMMAND_VOLUME_MUTE As Long = &H8 Public Sub SetSystemVolume(ByVal level As Integer) Dim hWndTaskbar As LongPtr Dim hWndVolumeCtrl As LongPtr Dim hWndParent As LongPtr Dim hWndChild As LongPtr Dim className As String hWndTaskbar = FindWindowEx(0, 0, "Shell_TrayWnd", vbNullString) If hWndTaskbar = 0 Then Exit Sub hWndVolumeCtrl = FindWindowEx(hWndTaskbar, 0, "TrayNotifyWnd", vbNullString) If hWndVolumeCtrl = 0 Then Exit Sub hWndParent = FindWindowEx(hWndVolumeCtrl, 0, "SysPager", vbNullString) If hWndParent = 0 Then Exit Sub hWndChild = FindWindowEx(hWndParent, 0, "ToolbarWindow32", vbNullString) If hWndChild = 0 Then Exit Sub ' get class name of the volume control className = Space(256) GetClassName hWndChild, StrPtr(className), Len(className) className = Left$(className, InStr(className, vbNullChar) - 1) ' find the volume control by window title hWndChild = FindWindowEx(hWndChild, 0, className, "Volume") If hWndChild = 0 Then Exit Sub SendMessage hWndChild, WM_APPCOMMAND, 0, APPCOMMAND_VOLUME_UP * &H10000 + level End Sub Public Sub MuteSystemVolume() Dim hWndTaskbar As LongPtr Dim hWndVolumeCtrl As LongPtr Dim hWndParent As LongPtr Dim hWndChild As LongPtr Dim className As String hWndTaskbar = FindWindowEx(0, 0, "Shell_TrayWnd", vbNullString) If hWndTaskbar = 0 Then Exit Sub hWndVolumeCtrl = FindWindowEx(hWndTaskbar, 0, "TrayNotifyWnd", vbNullString) If hWndVolumeCtrl = 0 Then Exit Sub hWndParent = FindWindowEx(hWndVolumeCtrl, 0, "SysPager", vbNullString) If hWndParent = 0 Then Exit Sub hWndChild = FindWindowEx(hWndParent, 0, "ToolbarWindow32", vbNullString) If hWndChild = 0 Then Exit Sub ' get class name of the volume control className = Space(256) GetClassName hWndChild, StrPtr(className), Len(className) className = Left$(className, InStr(className, vbNullChar) - 1) ' find the volume control by window title hWndChild = FindWindowEx(hWndChild, 0, className, "Volume") If hWndChild = 0 Then Exit Sub SendMessage hWndChild, WM_APPCOMMAND, 0, APPCOMMAND_VOLUME_MUTE * &H10000 End Sub 这段代码使用了 FindWindowEx 函数查找系统音量控制窗口,然后使用 SendMessage 函数发送消息实现音量调节和静音。注意,这段代码仅在英文操作系统上测试通过,非英文操作系统可能需要更改窗口标题或者类名。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值