改成win7 64位旗舰版+Office2010 64位后,原来的加载宏出现了问题

wshcw · 发表于 2011-12-25 16:15

本帖最后由 wshcw 于 2011-12-25 16:16 编辑

我的系统改成:win7 64位旗舰版+Office2010 64位后原来的加载宏出现了问题,红色部分有问题,代码如下:

Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub ComboBox1_Change()
If ComboBox1.Text = "式样一" Then
Image2.Visible = True
Image1.Visible = False
Label7.Enabled = False
TextBox3.Enabled = False
Else
Image1.Visible = True
Image2.Visible = False
Label7.Enabled = True
TextBox3.Enabled = True
End If
End Sub
Private Sub CommandButton1_Click()
With Selection
If .MergeCells = True Then
If ComboBox2.Text = "12" Then
.Font.Size = 12
.RowHeight = 42
ElseIf ComboBox2.Text = "9" Then
.RowHeight = 36
.Font.Size = 9
End If
End If
.WrapText = True
.HorizontalAlignment = xlLeft
End With
If ComboBox1.Text = "式样二" Then
With Selection
If Len(TextBox1.Text) <= 3 Then
If ComboBox2.Text = "12" Then
.ColumnWidth = 16
ElseIf ComboBox2.Text = "9" Then
.ColumnWidth = 10.5
End If
If Len(TextBox2.Text) >= 5 Then
.ColumnWidth = 27
End If
ElseIf Len(TextBox1.Text) = 4 Then
If ComboBox2.Text = "12" Then
.ColumnWidth = 22
ElseIf ComboBox2.Text = "9" Then
.ColumnWidth = 19.5
End If
If Len(TextBox2.Text) >= 5 Then
.ColumnWidth = 27
End If
ElseIf Len(TextBox1.Text) = 5 Then
If ComboBox2.Text = "12" Then
.ColumnWidth = 27
ElseIf ComboBox2.Text = "9" Then
.ColumnWidth = 22.5
End If
If Len(TextBox2.Text) >= 5 Then
.ColumnWidth = 27
End If
End If
If ComboBox2.Text = "12" Then
a = Int(.Width / 9.5)
Else
a = Int(.Width / 9.5) + 2.3
End If
.WrapText = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
If ComboBox2.Text = "12" Then
.Font.Size = 12
.RowHeight = 42
ElseIf ComboBox2.Text = "9" Then
.RowHeight = 36
.Font.Size = 9
End If
End With
Selection = Space(a) & TextBox1.Text & Chr(10) & Space(a / 2 + 1) & TextBox2.Text & Chr(10) & TextBox3.Text
Set myDocument = ActiveSheet
With myDocument.Shapes
.AddLine(Selection.Left, Selection.Top + 1, Selection.Left + Selection.Width, Selection.Top + Selection.Height / 2 + 1).Line.DashStyle = 1
.AddLine(Selection.Left - 1, Selection.Top, Selection.Left + Selection.Width / 2 - 1, Selection.Top + Selection.Height).Line.DashStyle = 1
End With
Else
With Selection
.WrapText = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Borders(xlDiagonalDown).LineStyle = xlContinuous
.Borders.LineStyle = xlContinuous
If Len(TextBox1.Text) <= 4 Then
If ComboBox2.Text = "12" Then
.Font.Size = 12
.RowHeight = 36.75
.ColumnWidth = 14
ElseIf ComboBox2.Text = "9" Then
.RowHeight = 24
.Font.Size = 9
.ColumnWidth = 10
End If
Else
If ComboBox2.Text = "12" Then
.Font.Size = 12
.RowHeight = 36.75
.ColumnWidth = 18
ElseIf ComboBox2.Text = "9" Then
.RowHeight = 24
.Font.Size = 9
.ColumnWidth = 12
End If
End If
Selection = Space(5) & TextBox1.Text & Chr(10) & Space(0) & TextBox2.Text
End With
End If
Unload Me
End Sub
Private Sub CommandButton2_Click()
If Selection.Count > 1 Then Exit Sub
Dim shap As Shape
For Each shap In ActiveSheet.Shapes
If (Not Application.Intersect(Range(shap.TopLeftCell.Address, shap.BottomRightCell.Address), ActiveCell) Is Nothing) Then
shap.Select
Selection.Delete
End If
Next
Selection.Clear
ActiveCell.EntireRow.AutoFit
End Sub
Private Sub TextBox1_Change()
If Len(TextBox1.Text) > 5 Then
MsgBox "字数太多了", 48, "提示"
TextBox1.Text = Mid(TextBox1.Text, 1, 5)
End If
End Sub
Private Sub TextBox2_Change()
If Len(TextBox2.Text) > 5 Then
MsgBox "字数太多了", 48, "提示"
TextBox1.Text = Mid(TextBox2.Text, 1, 5)
End If
End Sub
Private Sub TextBox3_Change()
If Len(TextBox3.Text) > 5 Then
MsgBox "字数太多了", 48, "提示"
TextBox1.Text = Mid(TextBox3.Text, 1, 5)
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.AddItem "式样一"
ComboBox1.AddItem "式样二"
ComboBox2.AddItem "9"
ComboBox2.AddItem "12"
ComboBox1.Text = "式样一"
ComboBox2.Text = "9"
Dim hWndForm&, hIcon&
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
hIcon = ExtractIcon(0, Environ("Systemroot") & "\explorer.exe", 10)
SendMessage hWndForm, &H80, False, hIcon
End Sub
============================================================================
请各位VBA高手帮忙改代码,使其在64位系统下能使用.谢谢了.

该贴已经同步到 wshcw的微博

chrisfang · 发表于 2011-12-25 16:46

API的声明部分改一下：

#If Win64 Then
Private Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

复制代码

另外调用API的时候定义变量的话有些也需要修改，手头没有64位，无法调试。

andysky · 发表于 2011-12-25 17:14

实际上，一些微软自己的Office插件目前都不能兼容64位Office 2010，包括Outlook Social Connector，更不用说第三方开发的插件了。

微软建议安装32位Office 2010而非64位版

liucqa · 发表于 2011-12-25 17:26

看一下pup7里面的例子
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As LongPtr
Private Declare PtrSafe Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As LongPtr, ByVal lpSubKey As String, phkResult As LongPtr) As Long
Private Declare PtrSafe Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As LongPtr, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Private Declare PtrSafe Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As LongPtr, ByVal sSubKey As String, ByRef hkeyResult As LongPtr) As Long
Private Declare PtrSafe Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As LongPtr, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
#Else
Private Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long
Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long
Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long
Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long
Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long
#End If

#If VBA7 And Win64 Then
      Dim TheKey As LongPtr
      Dim hKey As LongPtr
#Else
      Dim TheKey As Long
      Dim hKey As Long
#End If

liucqa · 发表于 2011-12-25 17:29

下面的示例演示如何在 Declare 语句中使用其中某些项。
VBA

Declare PtrSafe Function RegOpenKeyA Lib "advapi32.dll" (ByVal Key As LongPtr, ByVal SubKey As String, NewKey As LongPtr) As Long

请注意，没有 PtrSafe 属性的 Declare 语句被假定为与 64 位版本的 Office 2010 不兼容。

如前所述，有两个新的条件编译常量：VBA7 和 Win64。为确保与以前版本的 Office 的向后兼容性，可使用 VBA7 常量（这是较典型的情况）来防止 64 位代码在早期版本的 Office 中运行。对于在 32 位版本和 64 位版本之间有所不同的代码（例如调用数学 API，它对其 64 位版本使用 LongLong，对其 32 位版本使用 Long），可使用 Win64 常量。下面的代码演示如何使用这两个常量。
VBA

#if Win64 then
Declare PtrSafe Function MyMathFunc Lib "User32" (ByVal N As LongLong) As LongLong
#else
Declare Function MyMathFunc Lib "User32" (ByVal N As Long) As Long
#end if
#if VBA7 then
Declare PtrSafe Sub MessageBeep Lib "User32" (ByVal N AS Long)
#else
Declare Sub MessageBeep Lib "User32" (ByVal N AS Long)
#end if

总而言之，如果您编写 64 位代码并打算在以前版本的 Microsoft Office 中使用它，则需要使用 VBA7 条件编译常量。不过，如果您在 Office 2010 中编写 32 位代码，则该代码的工作方式与在以前版本的 Microsoft Office 中一样，无需使用编译常量。如果希望确保对 32 位版本使用 32 位语句，对 64 位版本使用 64 位语句，则最好选择使用 Win64 条件编译常量。
使用条件编译属性

下面的代码是需要更新的旧 VBA 代码的示例。请注意旧代码中更新为使用 LongPtr 的数据类型，因为它们引用句柄或指针

旧 VBA 代码
VBA

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

新 VBA 代码
VBA

#if VBA7 then ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As LongPtr
  lParam As LongPtr
  iImage As Long
End Type

#else ' Downlevel when using previous version of VBA7

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

#end if
Sub TestSHBrowseForFolder ()
Dim bInfo As BROWSEINFO
Dim pidList As Long

bInfo.pidlRoot = 0&
bInfo.ulFlags = &H1
pidList = SHBrowseForFolder(bInfo)
End Sub