اصلاح کدنویسی در vba به صورتی که در همه ویندوز ها قابل استفاده باشد .

[sabertb]

سلام
با کمک دوستان کد هایی رو در VBA نوشتم که در سیستم خودم که ویندوز 7 , 64 بیتی هست کاملا درست عمل میکنه ولی در ویندوز 32 بیتی و XP جواب نمیده . در واقع این کد نویسی ها رو انجام دادم تا برای همه موثر باشه چه کنم تا این مشکل حل بشه ! ؟
تصویر خطایی که تو XP میده بعد اصلا صفحه کدنویسی VBA دیگه باز نمیشه تو اون فایل

برای مثال در کد زیر که برای پروتکت کردن خودکار بر اساس یوزر نیم سیستم می باشد . تو اینترنت گشتم این مورد رو دیدم . شما به بینید این کد نویسی جواب میده ؟

Option Explicit
If VBA7 Then
            Declare PtrSafe Function WNetGetUser Lib "mpr.dll" _
                             Alias "WNetGetUserA" (ByVal lpName As String, _
                                                   ByVal lpUserName As String, lpnLength As Long) As Long
    Else
            Private Declare Function WNetGetUser Lib "mpr.dll" _
                             Alias "WNetGetUserA" (ByVal lpName As String, _
                                                   ByVal lpUserName As String, lpnLength As Long) As Long
    End If

Const NoError = 0        'The Function call was successful

Public Function GetUserName() As String

' Buffer size for the return string.
Const lpnLength As Integer = 255

    ' Get return buffer space.
Dim status As Integer

    ' For getting user information.
Dim lpName, lpUserName As String

    ' Assign the buffer size constant to lpUserName.
    lpUserName = Space$(lpnLength + 1)

    ' Get the log-on name of the person using product.
    status = WNetGetUser(lpName, lpUserName, lpnLength)

    ' See whether error occurred.
    If status = NoError Then
        ' This line removes the null character. Strings in C are null-
        ' terminated. Strings in Visual Basic are not null-terminated.
        ' The null character must be removed from the C strings to be used
        ' cleanly in Visual Basic.
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        ' An error occurred.
        GetUserName = "Unable to get the name."
        GoTo lbl_Exit
    End If

    ' Display the name of the person logged on to the machine.
    GetUserName = lpUserName
lbl_Exit:
    Exit Function
End Function 

[sabertb]

دوستان و اساتید راهکاری به نظرتون میرسه در مورد این مشکل ؟
چی کنیم فایلا با هر سیستم عاملی باز میشه درست کار کنه !؟

[sabertb]

دوستان راه حلی هست برای این مشکل ؟

[DOLFIN]

سلام. دوست عزیز در این پست مشکل شما حل شده و بنده هم در ویندوز 64 هم 32 تست کردم موردی نداشت. لطفا طبق کدهای این پست عمل کنید تا مشکلی پیش نیاد . موفق باشید.
تایین دسترسی با استفاده از یوزر های Login ویندوز ، تعریف شده در شبکه و تعریف دسترسی بر اساس یوزر ها با محدودیت سلولی

[FONT=Tahoma][COLOR=#000000][COLOR=#0000BB]Option Explicit[/COLOR][COLOR=#0000BB]
            [/COLOR][COLOR=#007700]Declare [/COLOR][COLOR=#0000BB]PtrSafe [/COLOR][COLOR=#007700]Function [/COLOR][COLOR=#0000BB]WNetGetUser Lib [/COLOR][COLOR=#DD0000]"mpr.dll" [/COLOR][COLOR=#0000BB]_
                             Alias [/COLOR][COLOR=#DD0000]"WNetGetUserA" [/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]ByVal lpName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]_
                                                   ByVal lpUserName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpnLength [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700]) As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700]

Const [/COLOR][COLOR=#0000BB]NoError [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]0        [/COLOR][COLOR=#DD0000]'The Function call was successful

Public Function GetUserName() As String

' [/COLOR][COLOR=#0000BB]Buffer size [/COLOR][COLOR=#007700]for [/COLOR][COLOR=#0000BB]the [/COLOR][COLOR=#007700]return [/COLOR][COLOR=#0000BB]string[/COLOR][COLOR=#007700].
Const [/COLOR][COLOR=#0000BB]lpnLength [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Integer [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]255

    [/COLOR][COLOR=#DD0000]' Get return buffer space.
Dim status As Integer

    ' [/COLOR][COLOR=#007700]For [/COLOR][COLOR=#0000BB]getting user information[/COLOR][COLOR=#007700].
[/COLOR][COLOR=#0000BB]Dim lpName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpUserName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String

    [/COLOR][COLOR=#DD0000]' Assign the buffer size constant to lpUserName.
    lpUserName = Space$(lpnLength + 1)

    ' [/COLOR][COLOR=#0000BB]Get the log[/COLOR][COLOR=#007700]-[/COLOR][COLOR=#0000BB]on name of the person using product[/COLOR][COLOR=#007700].
    [/COLOR][COLOR=#0000BB]status [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]WNetGetUser[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]lpName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpUserName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpnLength[/COLOR][COLOR=#007700])

    [/COLOR][COLOR=#DD0000]' See whether error occurred.
    If status = NoError Then
        ' [/COLOR][COLOR=#0000BB]This line removes the null character[/COLOR][COLOR=#007700]. [/COLOR][COLOR=#0000BB]Strings in C are null[/COLOR][COLOR=#007700]-
        [/COLOR][COLOR=#DD0000]' terminated. Strings in Visual Basic are not null-terminated.
        ' [/COLOR][COLOR=#0000BB]The null character must be removed from the C strings to be used
        [/COLOR][COLOR=#DD0000]' cleanly in Visual Basic.
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        ' [/COLOR][COLOR=#0000BB]An error occurred[/COLOR][COLOR=#007700].
        [/COLOR][COLOR=#0000BB]GetUserName [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"Unable to get the name."
        [/COLOR][COLOR=#007700]GoTo [/COLOR][COLOR=#0000BB]lbl_Exit
    End [/COLOR][COLOR=#007700]If

    [/COLOR][COLOR=#DD0000]' Display the name of the person logged on to the machine.
    GetUserName = lpUserName
lbl_Exit:
    Exit Function
End Function  [/COLOR][/COLOR][/FONT]

[sabertb]

سلام. دوست عزیز در این پست مشکل شما حل شده و بنده هم در ویندوز 64 هم 32 تست کردم موردی نداشت. لطفا طبق کدهای این پست عمل کنید تا مشکلی پیش نیاد . موفق باشید.
تایین دسترسی با استفاده از یوزر های Login ویندوز ، تعریف شده در شبکه و تعریف دسترسی بر اساس یوزر ها با محدودیت سلولی

[FONT=Tahoma][COLOR=#000000][COLOR=#0000BB]Option Explicit[/COLOR][COLOR=#0000BB]
            [/COLOR][COLOR=#007700]Declare [/COLOR][COLOR=#0000BB]PtrSafe [/COLOR][COLOR=#007700]Function [/COLOR][COLOR=#0000BB]WNetGetUser Lib [/COLOR][COLOR=#DD0000]"mpr.dll" [/COLOR][COLOR=#0000BB]_
                             Alias [/COLOR][COLOR=#DD0000]"WNetGetUserA" [/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]ByVal lpName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]_
                                                   ByVal lpUserName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpnLength [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700]) As [/COLOR][COLOR=#0000BB]Long[/COLOR][COLOR=#007700]

Const [/COLOR][COLOR=#0000BB]NoError [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]0        [/COLOR][COLOR=#DD0000]'The Function call was successful

Public Function GetUserName() As String

' [/COLOR][COLOR=#0000BB]Buffer size [/COLOR][COLOR=#007700]for [/COLOR][COLOR=#0000BB]the [/COLOR][COLOR=#007700]return [/COLOR][COLOR=#0000BB]string[/COLOR][COLOR=#007700].
Const [/COLOR][COLOR=#0000BB]lpnLength [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]Integer [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]255

    [/COLOR][COLOR=#DD0000]' Get return buffer space.
Dim status As Integer

    ' [/COLOR][COLOR=#007700]For [/COLOR][COLOR=#0000BB]getting user information[/COLOR][COLOR=#007700].
[/COLOR][COLOR=#0000BB]Dim lpName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpUserName [/COLOR][COLOR=#007700]As [/COLOR][COLOR=#0000BB]String

    [/COLOR][COLOR=#DD0000]' Assign the buffer size constant to lpUserName.
    lpUserName = Space$(lpnLength + 1)

    ' [/COLOR][COLOR=#0000BB]Get the log[/COLOR][COLOR=#007700]-[/COLOR][COLOR=#0000BB]on name of the person using product[/COLOR][COLOR=#007700].
    [/COLOR][COLOR=#0000BB]status [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000BB]WNetGetUser[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000BB]lpName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpUserName[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000BB]lpnLength[/COLOR][COLOR=#007700])

    [/COLOR][COLOR=#DD0000]' See whether error occurred.
    If status = NoError Then
        ' [/COLOR][COLOR=#0000BB]This line removes the null character[/COLOR][COLOR=#007700]. [/COLOR][COLOR=#0000BB]Strings in C are null[/COLOR][COLOR=#007700]-
        [/COLOR][COLOR=#DD0000]' terminated. Strings in Visual Basic are not null-terminated.
        ' [/COLOR][COLOR=#0000BB]The null character must be removed from the C strings to be used
        [/COLOR][COLOR=#DD0000]' cleanly in Visual Basic.
        lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
    Else
        ' [/COLOR][COLOR=#0000BB]An error occurred[/COLOR][COLOR=#007700].
        [/COLOR][COLOR=#0000BB]GetUserName [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#DD0000]"Unable to get the name."
        [/COLOR][COLOR=#007700]GoTo [/COLOR][COLOR=#0000BB]lbl_Exit
    End [/COLOR][COLOR=#007700]If

    [/COLOR][COLOR=#DD0000]' Display the name of the person logged on to the machine.
    GetUserName = lpUserName
lbl_Exit:
    Exit Function
End Function  [/COLOR][/COLOR][/FONT]

سلام ممنون هستم از شما
ولی من تست کردم در Xp جواب نداد تو ویندوز 7 32 بیتی تست نکردم ولی شما میگید اوکی هست حتما هست . من کلا ویندوز هارو گفتم چون تو XP ایش دیدم جواب نمیده .

[DOLFIN]

سلام دوست عزیز کدها مشکلی نداره.
به این مسیر بروید :
Control Panel >Add/Remove Programs>Microsoft Office2010
روی برنامه آفیس کلیک راست کنید و CHANGE رو انتخاب کنید.
بعد از نمایش صفحه نصب آفیس ، گزینه Add or Remove Features رو انتخاب و CONTINUE رو کلیک کنید.
به بخش Office Shared Features>Visual Basic for Applications بروید. اگر Visual Basic for Applications علامت ضربدر داشت یعنی می بایست Microsoft Office Visual Basic رو نصب کنید.
با سی دی آفیس میشه اینکارو کرد. البته ممکنه حتی با آپدیت هم بشه. موفق باشید