نوشته شده توسط
emami.sie
با سلام مجدد خدمت دوستان و اساتید محترم
طبق فرمایش جناب امیری اصلاحات رو انجام دادم...
فقط یه موضوع که خود جناب امیری هم بهش اشاره داشتن اینه که اگه بشه کدها رو یه جوری بسط داد که دستورات شرطی هم درش گنجانده بشه خیلی عالیه، چون من خودم الان حدود 10 تا برنامه طراحی کردم و دست چندین کاربره و اگه بخوام یکی یکی دستورات شرطی 64 و 32 بیتی رو درش اعمال کنم وحشتناک کار میبره، چون هر کدومش حدود 100 تا 150 تا عبارت Declare داره...
موفق و مؤید باشید
یا علی
سلام
برای ایجاد خودکار جملات شرطی ، کدهای زیر به کاربران فروم تقدیم می شود:
آقای امامی لطفا نسبت به اصلاح فایل تان و آزمودن کدهای زیر اقدام لازم به عمل آورید، ممنون می شوم.
Option Compare Database
Dim CountLines As Long
'************************************************* ********************************
Sub Win32_64DeclareCompatible(DBName As String)
Dim App As Access.Application, cnt As Long, LastLine As Long, mdlLineCount As Long
Dim db As DAO.Database, strDeclare As String
Dim mdl As Access.Module, mdlName As String, preProcLine As Long
Dim i As Long, j As Long, ChangedNum As Integer, strPWD As String
Set App = New Access.Application
strPWD = InputBox("در صورت وجود پسورد، آنرا تايپ کنيد")
App.OpenCurrentDatabase DBName, , strPWD
Set db = App.CurrentDb
cnt = db.Containers("Modules").Documents.Count - 1
For k = 0 To cnt
DoEvents
mdlName = db.Containers("Modules")(k).Name
App.DoCmd.OpenModule (mdlName)
Set mdl = App.Modules(mdlName)
With mdl
'Debug.Print mdlName
i = 1
preProcLine = 0
mdlLineCount = .CountOfLines
LastLine = i
Do While i < mdlLineCount
startSearch:
.Find "#If Win64", preProcLine, 1, preProcLine, -1
If .Find("Declare", i, 1, i, -1) Then
If preProcLine And i > preProcLine And LastLine < preProcLine Then
If i < LastLine Then Exit Do
i = preProcLine
.Find "#END If", i, 1, i, -1
preProcLine = i
LastLine = i
GoTo startSearch
End If
If i < LastLine Then Exit Do
strDeclare = EntireDeclareExpression(mdl, i)
If strDeclare <> "" Then
strDeclare = CreateConditional(strDeclare)
.DeleteLines i, CountLines
.InsertLines i, strDeclare
i = i + CountLines * 2 + 2
Else
i = i + 1
End If
mdlLineCount = mdl.CountOfLines
LastLine = i
preProcLine = i
ChangedNum = ChangedNum + 1
Else
Exit Do
End If
Loop
End With
DoCmd.Close acModule, mdlName, acSaveYes
Next
Set mdl = Nothing
Set db = Nothing
App.Quit acQuitSaveAll
Set App = Nothing
MsgBox "تعداد " & ChangedNum & " عبارت Declare جهت هماهنگي با" & vbCr & _
"سيستم هاي 32 و 64 بيتي آپديت شد"
End Sub
'************************************************* ********************************
Private Function EntireDeclareExpression(mdl As Module, iLine As Long) As String
Dim s As String
CountLines = 1
With mdl
mdl.Find "Declare", iLine, 1, -1, -1
s = vbTab & LTrim(.Lines(iLine, CountLines))
k = InStr(1, s, "'", vbTextCompare) 'Check quotation marks if Declare used in comments
If InStr(1, s, "Declare", vbTextCompare) > k And k > 0 Then
EntireDeclareExpression = ""
Exit Function
End If
Do While Right(s, 1) = "_"
CountLines = CountLines + 1
.ReplaceLine iLine + CountLines - 1, vbTab & LTrim(.Lines(iLine + CountLines - 1, 1))
s = vbTab & LTrim(.Lines(iLine, CountLines))
Loop
End With
EntireDeclareExpression = s
End Function
'************************************************* *******************
Private Function CreateConditional(strDeclare As String) As String
Dim s As String
s = "#If Win64 Then" & vbCr
s = s & AddPtrsafe(strDeclare) & vbCr
s = s & "#Else" & vbCr
s = s & DelPtrsafe(strDeclare) & vbCr
s = s & "#End If" & vbCr
CreateConditional = s
End Function
'************************************************* *******************
Private Function AddPtrsafe(strDeclare As String) As String
Dim i As Integer, lStr As String, rStr As String
i = InStr(1, strDeclare, "Ptrsafe", vbTextCompare)
If i = 0 Then
AddPtrsafe = Replace(strDeclare, "Declare", "Declare Ptrsafe", , , vbTextCompare)
Else
AddPtrsafe = strDeclare
End If
End Function
'************************************************* *******************
Private Function DelPtrsafe(strDeclare As String) As String
DelPtrsafe = Replace(strDeclare, "Ptrsafe", "", , , vbTextCompare)
End Function
پاسخ با نقل قول
